1390 files changed, 417489 insertions, 0 deletions

diff --git a/SRC/Makefile b/SRC/Makefile
new file mode 100644
index 00000000..2d79fcc2
--- /dev/null
+++ b/SRC/Makefile
@@ -0,0 +1,341 @@
+include ../make.inc
+
+#######################################################################
+#  This is the makefile to create a library for LAPACK.
+#  The files are organized as follows:
+#       ALLAUX -- Auxiliary routines called from all precisions
+#       SCLAUX -- Auxiliary routines called from both REAL and COMPLEX
+#       DZLAUX -- Auxiliary routines called from both DOUBLE PRECISION
+#                 and COMPLEX*16
+#       SLASRC -- Single precision real LAPACK routines
+#       CLASRC -- Single precision complex LAPACK routines
+#       DLASRC -- Double precision real LAPACK routines
+#       ZLASRC -- Double precision complex LAPACK routines
+#
+#  The library can be set up to include routines for any combination
+#  of the four precisions.  To create or add to the library, enter make
+#  followed by one or more of the precisions desired.  Some examples:
+#       make single
+#       make single complex
+#       make single double complex complex16
+#  Alternatively, the command
+#       make
+#  without any arguments creates a library of all four precisions.
+#  The library is called
+#       lapack.a
+#  and is created at the next higher directory level.
+#
+#  To remove the object files after the library is created, enter
+#       make clean
+#  On some systems, you can force the source files to be recompiled by
+#  entering (for example)
+#       make single FRC=FRC
+#
+#  ***Note***
+#  The functions lsame, second, dsecnd, slamch, and dlamch may have
+#  to be installed before compiling the library.  Refer to the
+#  installation guide, LAPACK Working Note 41, for instructions.
+#
+#######################################################################
+ 
+ALLAUX = ilaenv.o ieeeck.o lsamen.o xerbla.o xerbla_array.o iparmq.o	\
+	ila_len_trim.o ../INSTALL/ilaver.o ../INSTALL/lsame.o
+
+SCLAUX = \
+   sbdsdc.o \
+   sbdsqr.o sdisna.o slabad.o slacpy.o sladiv.o slae2.o  slaebz.o \
+   slaed0.o slaed1.o slaed2.o slaed3.o slaed4.o slaed5.o slaed6.o \
+   slaed7.o slaed8.o slaed9.o slaeda.o slaev2.o slagtf.o \
+   slagts.o slamrg.o slanst.o \
+   slapy2.o slapy3.o slarnv.o \
+   slarra.o slarrb.o slarrc.o slarrd.o slarre.o slarrf.o slarrj.o \
+   slarrk.o slarrr.o slaneg.o \
+   slartg.o slaruv.o slas2.o  slascl.o \
+   slasd0.o slasd1.o slasd2.o slasd3.o slasd4.o slasd5.o slasd6.o \
+   slasd7.o slasd8.o slasda.o slasdq.o slasdt.o \
+   slaset.o slasq1.o slasq2.o slasq3.o slazq3.o slasq4.o slazq4.o slasq5.o slasq6.o \
+   slasr.o  slasrt.o slassq.o slasv2.o spttrf.o sstebz.o sstedc.o \
+   ssteqr.o ssterf.o slaisnan.o sisnan.o \
+   ../INSTALL/slamch.o ../INSTALL/second_$(TIMER).o
+
+DZLAUX = \
+   dbdsdc.o \
+   dbdsqr.o ddisna.o dlabad.o dlacpy.o dladiv.o dlae2.o  dlaebz.o \
+   dlaed0.o dlaed1.o dlaed2.o dlaed3.o dlaed4.o dlaed5.o dlaed6.o \
+   dlaed7.o dlaed8.o dlaed9.o dlaeda.o dlaev2.o dlagtf.o \
+   dlagts.o dlamrg.o dlanst.o \
+   dlapy2.o dlapy3.o dlarnv.o \
+   dlarra.o dlarrb.o dlarrc.o dlarrd.o dlarre.o dlarrf.o dlarrj.o \
+   dlarrk.o dlarrr.o dlaneg.o \
+   dlartg.o dlaruv.o dlas2.o  dlascl.o \
+   dlasd0.o dlasd1.o dlasd2.o dlasd3.o dlasd4.o dlasd5.o dlasd6.o \
+   dlasd7.o dlasd8.o dlasda.o dlasdq.o dlasdt.o \
+   dlaset.o dlasq1.o dlasq2.o dlasq3.o dlazq3.o dlasq4.o dlazq4.o dlasq5.o dlasq6.o \
+   dlasr.o  dlasrt.o dlassq.o dlasv2.o dpttrf.o dstebz.o dstedc.o \
+   dsteqr.o dsterf.o dlaisnan.o disnan.o \
+   ../INSTALL/dlamch.o ../INSTALL/dsecnd_$(TIMER).o
+
+SLASRC = \
+   sgbbrd.o sgbcon.o sgbequ.o sgbrfs.o sgbsv.o  \
+   sgbsvx.o sgbtf2.o sgbtrf.o sgbtrs.o sgebak.o sgebal.o sgebd2.o \
+   sgebrd.o sgecon.o sgeequ.o sgees.o  sgeesx.o sgeev.o  sgeevx.o \
+   sgegs.o  sgegv.o  sgehd2.o sgehrd.o sgelq2.o sgelqf.o \
+   sgels.o  sgelsd.o sgelss.o sgelsx.o sgelsy.o sgeql2.o sgeqlf.o \
+   sgeqp3.o sgeqpf.o sgeqr2.o sgeqrf.o sgerfs.o sgerq2.o sgerqf.o \
+   sgesc2.o sgesdd.o sgesv.o  sgesvd.o sgesvx.o sgetc2.o sgetf2.o \
+   sgetrf.o sgetri.o \
+   sgetrs.o sggbak.o sggbal.o sgges.o  sggesx.o sggev.o  sggevx.o \
+   sggglm.o sgghrd.o sgglse.o sggqrf.o \
+   sggrqf.o sggsvd.o sggsvp.o sgtcon.o sgtrfs.o sgtsv.o  \
+   sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \
+   shsein.o shseqr.o slabrd.o slacon.o slacn2.o \
+   slaein.o slaexc.o slag2.o  slags2.o slagtm.o slagv2.o slahqr.o \
+   slahrd.o slahr2.o slaic1.o slaln2.o slals0.o slalsa.o slalsd.o \
+   slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \
+   slansy.o slantb.o slantp.o slantr.o slanv2.o \
+   slapll.o slapmt.o \
+   slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \
+   slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \
+   slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
+   slarf.o  slarfb.o slarfg.o slarft.o slarfx.o slargv.o \
+   slarrv.o slartv.o slarfp.o \
+   slarz.o  slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o \
+   slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \
+   slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \
+   sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \
+   sorgrq.o sorgtr.o sorm2l.o sorm2r.o \
+   sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \
+   sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \
+   spbstf.o spbsv.o  spbsvx.o \
+   spbtf2.o spbtrf.o spbtrs.o spocon.o spoequ.o sporfs.o sposv.o  \
+   sposvx.o spotf2.o spotrf.o spotri.o spotrs.o sppcon.o sppequ.o \
+   spprfs.o sppsv.o  sppsvx.o spptrf.o spptri.o spptrs.o sptcon.o \
+   spteqr.o sptrfs.o sptsv.o  sptsvx.o spttrs.o sptts2.o srscl.o  \
+   ssbev.o  ssbevd.o ssbevx.o ssbgst.o ssbgv.o  ssbgvd.o ssbgvx.o \
+   ssbtrd.o sspcon.o sspev.o  sspevd.o sspevx.o sspgst.o \
+   sspgv.o  sspgvd.o sspgvx.o ssprfs.o sspsv.o  sspsvx.o ssptrd.o \
+   ssptrf.o ssptri.o ssptrs.o sstegr.o sstein.o sstev.o  sstevd.o sstevr.o \
+   sstevx.o ssycon.o ssyev.o  ssyevd.o ssyevr.o ssyevx.o ssygs2.o \
+   ssygst.o ssygv.o  ssygvd.o ssygvx.o ssyrfs.o ssysv.o  ssysvx.o \
+   ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytrs.o stbcon.o \
+   stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \
+   stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \
+   stptrs.o \
+   strcon.o strevc.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \
+   strti2.o strtri.o strtrs.o stzrqf.o stzrzf.o sstemr.o
+
+CLASRC = \
+   cbdsqr.o cgbbrd.o cgbcon.o cgbequ.o cgbrfs.o cgbsv.o  cgbsvx.o \
+   cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \
+   cgecon.o cgeequ.o cgees.o  cgeesx.o cgeev.o  cgeevx.o \
+   cgegs.o  cgegv.o  cgehd2.o cgehrd.o cgelq2.o cgelqf.o \
+   cgels.o  cgelsd.o cgelss.o cgelsx.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \
+   cgeqpf.o cgeqr2.o cgeqrf.o cgerfs.o cgerq2.o cgerqf.o \
+   cgesc2.o cgesdd.o cgesv.o  cgesvd.o cgesvx.o cgetc2.o cgetf2.o cgetrf.o \
+   cgetri.o cgetrs.o \
+   cggbak.o cggbal.o cgges.o  cggesx.o cggev.o  cggevx.o cggglm.o \
+   cgghrd.o cgglse.o cggqrf.o cggrqf.o \
+   cggsvd.o cggsvp.o \
+   cgtcon.o cgtrfs.o cgtsv.o  cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o  \
+   chbevd.o chbevx.o chbgst.o chbgv.o  chbgvd.o chbgvx.o chbtrd.o \
+   checon.o cheev.o  cheevd.o cheevr.o cheevx.o chegs2.o chegst.o \
+   chegv.o  chegvd.o chegvx.o cherfs.o chesv.o  chesvx.o chetd2.o \
+   chetf2.o chetrd.o \
+   chetrf.o chetri.o chetrs.o chgeqz.o chpcon.o chpev.o  chpevd.o \
+   chpevx.o chpgst.o chpgv.o  chpgvd.o chpgvx.o chprfs.o chpsv.o  \
+   chpsvx.o \
+   chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \
+   clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \
+   claed0.o claed7.o claed8.o \
+   claein.o claesy.o claev2.o clags2.o clagtm.o \
+   clahef.o clahqr.o \
+   clahrd.o clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \
+   clanhb.o clanhe.o \
+   clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \
+   clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \
+   claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqsb.o \
+   claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \
+   claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \
+   clarf.o  clarfb.o clarfg.o clarft.o clarfp.o \
+   clarfx.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \
+   clarz.o  clarzb.o clarzt.o clascl.o claset.o clasr.o  classq.o \
+   claswp.o clasyf.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
+   clatzm.o clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o  \
+   cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \
+   cposv.o  cposvx.o cpotf2.o cpotrf.o cpotri.o cpotrs.o cppcon.o \
+   cppequ.o cpprfs.o cppsv.o  cppsvx.o cpptrf.o cpptri.o cpptrs.o \
+   cptcon.o cpteqr.o cptrfs.o cptsv.o  cptsvx.o cpttrf.o cpttrs.o cptts2.o \
+   crot.o   cspcon.o cspmv.o  cspr.o   csprfs.o cspsv.o  \
+   cspsvx.o csptrf.o csptri.o csptrs.o csrscl.o cstedc.o \
+   cstegr.o cstein.o csteqr.o csycon.o csymv.o  \
+   csyr.o   csyrfs.o csysv.o  csysvx.o csytf2.o csytrf.o csytri.o \
+   csytrs.o ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \
+   ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \
+   ctprfs.o ctptri.o \
+   ctptrs.o ctrcon.o ctrevc.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \
+   ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrqf.o ctzrzf.o cung2l.o cung2r.o \
+   cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \
+   cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o \
+   cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \
+   cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o
+
+DLASRC = \
+   dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o  \
+   dgbsvx.o dgbtf2.o dgbtrf.o dgbtrs.o dgebak.o dgebal.o dgebd2.o \
+   dgebrd.o dgecon.o dgeequ.o dgees.o  dgeesx.o dgeev.o  dgeevx.o \
+   dgegs.o  dgegv.o  dgehd2.o dgehrd.o dgelq2.o dgelqf.o \
+   dgels.o  dgelsd.o dgelss.o dgelsx.o dgelsy.o dgeql2.o dgeqlf.o \
+   dgeqp3.o dgeqpf.o dgeqr2.o dgeqrf.o dgerfs.o dgerq2.o dgerqf.o \
+   dgesc2.o dgesdd.o dgesv.o  dgesvd.o dgesvx.o dgetc2.o dgetf2.o \
+   dgetrf.o dgetri.o \
+   dgetrs.o dggbak.o dggbal.o dgges.o  dggesx.o dggev.o  dggevx.o \
+   dggglm.o dgghrd.o dgglse.o dggqrf.o \
+   dggrqf.o dggsvd.o dggsvp.o dgtcon.o dgtrfs.o dgtsv.o  \
+   dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \
+   dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \
+   dlaein.o dlaexc.o dlag2.o  dlags2.o dlagtm.o dlagv2.o dlahqr.o \
+   dlahrd.o dlahr2.o dlaic1.o dlaln2.o dlals0.o dlalsa.o dlalsd.o \
+   dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \
+   dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \
+   dlapll.o dlapmt.o \
+   dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \
+   dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \
+   dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
+   dlarf.o  dlarfb.o dlarfg.o dlarft.o dlarfx.o dlargv.o \
+   dlarrv.o dlartv.o dlarfp.o \
+   dlarz.o  dlarzb.o dlarzt.o dlaswp.o dlasy2.o dlasyf.o \
+   dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o dlauu2.o \
+   dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \
+   dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \
+   dorgrq.o dorgtr.o dorm2l.o dorm2r.o \
+   dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \
+   dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \
+   dpbstf.o dpbsv.o  dpbsvx.o \
+   dpbtf2.o dpbtrf.o dpbtrs.o dpocon.o dpoequ.o dporfs.o dposv.o  \
+   dposvx.o dpotf2.o dpotrf.o dpotri.o dpotrs.o dppcon.o dppequ.o \
+   dpprfs.o dppsv.o  dppsvx.o dpptrf.o dpptri.o dpptrs.o dptcon.o \
+   dpteqr.o dptrfs.o dptsv.o  dptsvx.o dpttrs.o dptts2.o drscl.o  \
+   dsbev.o  dsbevd.o dsbevx.o dsbgst.o dsbgv.o  dsbgvd.o dsbgvx.o \
+   dsbtrd.o  dspcon.o dspev.o  dspevd.o dspevx.o dspgst.o \
+   dspgv.o  dspgvd.o dspgvx.o dsprfs.o dspsv.o  dspsvx.o dsptrd.o \
+   dsptrf.o dsptri.o dsptrs.o dstegr.o dstein.o dstev.o  dstevd.o dstevr.o \
+   dstevx.o dsycon.o dsyev.o  dsyevd.o dsyevr.o \
+   dsyevx.o dsygs2.o dsygst.o dsygv.o  dsygvd.o dsygvx.o dsyrfs.o \
+   dsysv.o  dsysvx.o \
+   dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytrs.o dtbcon.o \
+   dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \
+   dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \
+   dtptrs.o \
+   dtrcon.o dtrevc.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \
+   dtrti2.o dtrtri.o dtrtrs.o dtzrqf.o dtzrzf.o dstemr.o \
+   dsgesv.o dlag2s.o slag2d.o
+
+ZLASRC = \
+   zbdsqr.o zgbbrd.o zgbcon.o zgbequ.o zgbrfs.o zgbsv.o  zgbsvx.o \
+   zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \
+   zgecon.o zgeequ.o zgees.o  zgeesx.o zgeev.o  zgeevx.o \
+   zgegs.o  zgegv.o  zgehd2.o zgehrd.o zgelq2.o zgelqf.o \
+   zgels.o  zgelsd.o zgelss.o zgelsx.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \
+   zgeqpf.o zgeqr2.o zgeqrf.o zgerfs.o zgerq2.o zgerqf.o \
+   zgesc2.o zgesdd.o zgesv.o  zgesvd.o zgesvx.o zgetc2.o zgetf2.o zgetrf.o \
+   zgetri.o zgetrs.o \
+   zggbak.o zggbal.o zgges.o  zggesx.o zggev.o  zggevx.o zggglm.o \
+   zgghrd.o zgglse.o zggqrf.o zggrqf.o \
+   zggsvd.o zggsvp.o \
+   zgtcon.o zgtrfs.o zgtsv.o  zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o  \
+   zhbevd.o zhbevx.o zhbgst.o zhbgv.o  zhbgvd.o zhbgvx.o zhbtrd.o \
+   zhecon.o zheev.o  zheevd.o zheevr.o zheevx.o zhegs2.o zhegst.o \
+   zhegv.o  zhegvd.o zhegvx.o zherfs.o zhesv.o  zhesvx.o zhetd2.o \
+   zhetf2.o zhetrd.o \
+   zhetrf.o zhetri.o zhetrs.o zhgeqz.o zhpcon.o zhpev.o  zhpevd.o \
+   zhpevx.o zhpgst.o zhpgv.o  zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o  \
+   zhpsvx.o \
+   zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \
+   zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \
+   zlaed0.o zlaed7.o zlaed8.o \
+   zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \
+   zlahef.o zlahqr.o \
+   zlahrd.o zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \
+   zlangt.o zlanhb.o \
+   zlanhe.o \
+   zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \
+   zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \
+   zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqsb.o \
+   zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \
+   zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \
+   zlarcm.o zlarf.o  zlarfb.o \
+   zlarfg.o zlarft.o zlarfp.o \
+   zlarfx.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \
+   zlarz.o  zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o  \
+   zlassq.o zlaswp.o zlasyf.o \
+   zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlatzm.o zlauu2.o \
+   zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o  \
+   zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \
+   zposv.o  zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zppcon.o \
+   zppequ.o zpprfs.o zppsv.o  zppsvx.o zpptrf.o zpptri.o zpptrs.o \
+   zptcon.o zpteqr.o zptrfs.o zptsv.o  zptsvx.o zpttrf.o zpttrs.o zptts2.o \
+   zrot.o   zspcon.o zspmv.o  zspr.o   zsprfs.o zspsv.o  \
+   zspsvx.o zsptrf.o zsptri.o zsptrs.o zdrscl.o zstedc.o \
+   zstegr.o zstein.o zsteqr.o zsycon.o zsymv.o  \
+   zsyr.o   zsyrfs.o zsysv.o  zsysvx.o zsytf2.o zsytrf.o zsytri.o \
+   zsytrs.o ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \
+   ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \
+   ztprfs.o ztptri.o \
+   ztptrs.o ztrcon.o ztrevc.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \
+   ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrqf.o ztzrzf.o zung2l.o \
+   zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \
+   zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o \
+   zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \
+   zunmtr.o zupgtr.o \
+   zupmtr.o izmax1.o dzsum1.o zstemr.o \
+   zcgesv.o zlag2c.o clag2z.o
+
+all: ../$(LAPACKLIB)
+
+ALLOBJ=$(SLASRC) $(DLASRC) $(CLASRC) $(ZLASRC) $(SCLAUX) $(DZLAUX)	\
+	$(ALLAUX)
+
+../$(LAPACKLIB): $(ALLOBJ)
+	$(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ)
+	$(RANLIB) $@
+
+single: $(SLASRC) $(ALLAUX) $(SCLAUX) 
+	$(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(SLASRC) $(ALLAUX) \
+	$(SCLAUX)
+	$(RANLIB) ../$(LAPACKLIB)
+
+complex: $(CLASRC) $(ALLAUX) $(SCLAUX)
+	$(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(CLASRC) $(ALLAUX) \
+	$(SCLAUX)
+	$(RANLIB) ../$(LAPACKLIB)
+
+double: $(DLASRC) $(ALLAUX) $(DZLAUX)
+	$(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(DLASRC) $(ALLAUX) \
+	$(DZLAUX)
+	$(RANLIB) ../$(LAPACKLIB)
+
+complex16: $(ZLASRC) $(ALLAUX) $(DZLAUX)
+	$(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(ZLASRC) $(ALLAUX) \
+	$(DZLAUX)
+	$(RANLIB) ../$(LAPACKLIB)
+
+$(ALLAUX): $(FRC)
+$(SCLAUX): $(FRC)
+$(DZLAUX): $(FRC)
+$(SLASRC): $(FRC)
+$(CLASRC): $(FRC)
+$(DLASRC): $(FRC)
+$(ZLASRC): $(FRC)
+
+FRC:
+	@FRC=$(FRC)
+
+clean:
+	rm -f *.o
+
+.f.o: 
+	$(FORTRAN) $(OPTS) -c $< -o $@
+
+slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@
+dlaruv.o: dlaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@
+
diff --git a/SRC/VARIANTS/Makefile b/SRC/VARIANTS/Makefile
new file mode 100644
index 00000000..42446eb5
--- /dev/null
+++ b/SRC/VARIANTS/Makefile
@@ -0,0 +1,67 @@
+include ../../make.inc
+
+#######################################################################
+#  This is the makefile to create a the variants libraries for LAPACK.
+#  The files are organized as follows:
+#       CHOLRL -- Right looking block version of the algorithm, calling Level 3 BLAS
+#       CHOLTOP -- Top looking block version of the algorithm, calling Level 3 BLAS
+#       LUCR -- Crout Level 3 BLAS version of LU factorization
+#       LULL -- left-looking Level 3 BLAS version of LU factorization
+#       QRLL -- left-looking Level 3 BLAS version of QR factorization
+#       LUREC -- an iterative version of Sivan Toledo's recursive LU algorithm[1].  
+#       For square matrices, this iterative versions should
+#       be within a factor of two of the optimum number of memory transfers.
+#
+# [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
+#  Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+#  1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+#######################################################################
+
+VARIANTSDIR=LIB
+
+CHOLRL = cholesky/RL/cpotrf.o cholesky/RL/dpotrf.o cholesky/RL/spotrf.o cholesky/RL/zpotrf.o
+
+CHOLTOP = cholesky/TOP/cpotrf.o cholesky/TOP/dpotrf.o cholesky/TOP/spotrf.o cholesky/TOP/zpotrf.o
+
+LUCR = lu/CR/cgetrf.o lu/CR/dgetrf.o lu/CR/sgetrf.o lu/CR/zgetrf.o
+
+LULL = lu/LL/cgetrf.o lu/LL/dgetrf.o lu/LL/sgetrf.o lu/LL/zgetrf.o
+
+LUREC = lu/REC/cgetrf.o lu/REC/dgetrf.o lu/REC/sgetrf.o lu/REC/zgetrf.o
+
+QRLL = qr/LL/cgeqrf.o qr/LL/dgeqrf.o qr/LL/sgeqrf.o qr/LL/zgeqrf.o  qr/LL/sceil.o
+
+
+all: cholrl choltop lucr lull lurec qrll
+
+cholrl: $(CHOLRL)
+	$(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/cholrl.a $(CHOLRL)
+	$(RANLIB) $(VARIANTSDIR)/cholrl.a
+
+choltop: $(CHOLTOP)
+	$(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/choltop.a $(CHOLTOP)
+	$(RANLIB) $(VARIANTSDIR)/choltop.a
+
+lucr: $(LUCR)
+	$(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lucr.a $(LUCR)
+	$(RANLIB) $(VARIANTSDIR)/lucr.a
+
+lull: $(LULL)
+	$(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lull.a $(LULL)
+	$(RANLIB) $(VARIANTSDIR)/lull.a
+
+lurec: $(LUREC)
+	$(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lurec.a $(LUREC)
+	$(RANLIB) $(VARIANTSDIR)/lurec.a
+	
+qrll: $(QRLL)
+	$(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/qrll.a  $(QRLL)
+	$(RANLIB) $(VARIANTSDIR)/qrll.a
+
+
+.f.o: 
+	$(FORTRAN) $(OPTS) -c $< -o $@
+	
+clean:
+	rm -f $(CHOLRL) $(CHOLTOP) $(LUCR) $(LULL) $(LUREC) $(QRLL) \
+	      $(VARIANTSDIR)/*.a
\ No newline at end of file
diff --git a/SRC/VARIANTS/README b/SRC/VARIANTS/README
new file mode 100644
index 00000000..6b4f3258
--- /dev/null
+++ b/SRC/VARIANTS/README
@@ -0,0 +1,84 @@
+   		   ===============
+ 		   = README File =
+		   ===============
+
+This README File is for the LAPACK driver variants.
+It is composed of 5 sections:
+	- Description: contents a quick description of each of the variants. For a more detailed description please refer to LAWN XXX.
+	- Build
+	- Testing
+	- Linking your program
+	- Support
+	
+Author: Julie LANGOU, May 2008
+
+===============
+= DESCRIPTION =
+===============
+
+This directory contains several variants of LAPACK routines in single/double/complex/double complex precision:
+	- [sdcz]getrf with LU Crout Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/lu/CR
+	- [sdcz]getrf with LU Left Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/lu/LL
+	- [sdcz]getrf with Sivan Toledo's recursive LU algorithm [1] - Directory: SRC/VARIANTS/lu/REC
+	- [sdcz]geqrf with QR Left Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/qr/LL
+	- [sdcz]potrf with Cholesky Right Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/cholesky/RL
+	- [sdcz]potrf with Cholesky Top Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/cholesky/TOP
+	
+References:For a more detailed description please refer to
+	- [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+          1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+	- [2]LAWN XXX
+	
+=========
+= BUILD =
+=========
+	
+These variants are compiled by default in the build process but they are not tested by default.
+The build process creates one new library per variants in the four arithmetics (singel/double/comple/double complex).
+The libraries are in the SRC/VARIANTS/LIB directory.
+
+Corresponding libraries created in SRC/VARIANTS/LIB:
+	- LU Crout : lucr.a
+	- LU Left Looking : lull.a
+	- LU Sivan Toledo's recursive : lurec.a
+	- QR Left Looking : qrll.a
+	- Cholesky Right Looking : cholrl.a
+	- Cholesky Top : choltop.a
+	
+
+===========
+= TESTING =
+===========
+
+To test these variants you can type 'make variants-testing'
+This will rerun the linear methods testings once per variants and append the short name of the variants to the output files.
+You should then see the following files in the TESTING directory:
+[scdz]test_cholrl.out
+[scdz]test_choltop.out
+[scdz]test_lucr.out
+[scdz]test_lull.out
+[scdz]test_lurec.out
+[scdz]test_qrll.out
+
+========================
+= LINKING YOUR PROGRAM =
+========================
+
+You just need to add the variants methods library in your linking sequence before your lapack libary.
+Here is a quick example for LU
+
+Default using LU Right Looking version:
+ $(FORTRAN) -c myprog.f
+ $(FORTRAN) -o myexe myprog.o $(LAPACKLIB) $(BLASLIB)
+
+Using LU Left Looking version:
+ $(FORTRAN) -c myprog.f
+ $(FORTRAN) -o myexe myprog.o $(PATH TO LAPACK/SRC/VARIANTS/LIB)/lull.a $(LAPACKLIB) $(BLASLIB)
+
+===========
+= SUPPORT =
+===========
+
+You can use either LAPACK forum or the LAPACK mailing list to get support.
+LAPACK forum : http://icl.cs.utk.edu/lapack-forum
+LAPACK mailing list : lapack@cs.utk.edu
diff --git a/SRC/VARIANTS/cholesky/RL/cpotrf.f b/SRC/VARIANTS/cholesky/RL/cpotrf.f
new file mode 100644
index 00000000..a6d194cb
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/cpotrf.f
@@ -0,0 +1,187 @@
+      SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOTRF computes the Cholesky factorization of a real 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 right looking 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 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 ..
+      REAL               ONE
+      COMPLEX            CONE
+      PARAMETER          ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CPOTF2, CHERK, CTRSM, 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( 'CPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'CPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL CPOTF2( 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 CPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                 Updating the trailing submatrix.
+*
+                  CALL CTRSM( 'Left', 'Upper', 'Conjugate Transpose', 
+     $                        'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
+     $                        LDA, A( J, J+JB ), LDA )
+                  CALL CHERK( 'Upper', 'Conjugate transpose', N-J-JB+1, 
+     $                        JB, -ONE, A( J, J+JB ), LDA, 
+     $                        ONE, A( J+JB, 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 CPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                Updating the trailing submatrix.
+*
+                 CALL CTRSM( 'Right', 'Lower', 'Conjugate Transpose', 
+     $                       'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
+     $                       LDA, A( J+JB, J ), LDA )
+
+                 CALL CHERK( 'Lower', 'No Transpose', N-J-JB+1, JB, 
+     $                       -ONE, A( J+JB, J ), LDA, 
+     $                       ONE, A( J+JB, J+JB ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = INFO + J - 1
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of CPOTRF
+*
+      END
diff --git a/SRC/VARIANTS/cholesky/RL/dpotrf.f b/SRC/VARIANTS/cholesky/RL/dpotrf.f
new file mode 100644
index 00000000..72603304
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/dpotrf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. 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 right looking 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 DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                 Updating the trailing submatrix.
+*
+                  CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+     $                        JB, N-J-JB+1, ONE, A( J, J ), LDA,
+     $                        A( J, J+JB ), LDA )
+                  CALL DSYRK( 'Upper', 'Transpose', N-J-JB+1, JB, -ONE,
+     $                        A( J, J+JB ), LDA, 
+     $                        ONE, A( J+JB, 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 DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                Updating the trailing submatrix.
+*
+                 CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+     $                       N-J-JB+1, JB, ONE, A( J, J ), LDA,
+     $                       A( J+JB, J ), LDA )
+
+                 CALL DSYRK( 'Lower', 'No Transpose', N-J-JB+1, JB, 
+     $                       -ONE, A( J+JB, J ), LDA, 
+     $                       ONE, A( J+JB, J+JB ), 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/VARIANTS/cholesky/RL/spotrf.f b/SRC/VARIANTS/cholesky/RL/spotrf.f
new file mode 100644
index 00000000..3375902a
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/spotrf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOTRF 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 right looking 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SPOTF2, SSYRK, STRSM, 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( 'SPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'SPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL SPOTF2( 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 SPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                 Updating the trailing submatrix.
+*
+                  CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+     $                        JB, N-J-JB+1, ONE, A( J, J ), LDA,
+     $                        A( J, J+JB ), LDA )
+                  CALL SSYRK( 'Upper', 'Transpose', N-J-JB+1, JB, -ONE,
+     $                        A( J, J+JB ), LDA, 
+     $                        ONE, A( J+JB, 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 SPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                Updating the trailing submatrix.
+*
+                 CALL STRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+     $                       N-J-JB+1, JB, ONE, A( J, J ), LDA,
+     $                       A( J+JB, J ), LDA )
+
+                 CALL SSYRK( 'Lower', 'No Transpose', N-J-JB+1, JB, 
+     $                       -ONE, A( J+JB, J ), LDA, 
+     $                       ONE, A( J+JB, J+JB ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = INFO + J - 1
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of SPOTRF
+*
+      END
diff --git a/SRC/VARIANTS/cholesky/RL/zpotrf.f b/SRC/VARIANTS/cholesky/RL/zpotrf.f
new file mode 100644
index 00000000..b2bce7f6
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/zpotrf.f
@@ -0,0 +1,187 @@
+      SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOTRF computes the Cholesky factorization of a real 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 right looking 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           ZGEMM, ZPOTF2, ZHERK, ZTRSM, 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( '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 ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                 Updating the trailing submatrix.
+*
+                  CALL ZTRSM( 'Left', 'Upper', 'Conjugate Transpose', 
+     $                        'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
+     $                        LDA, A( J, J+JB ), LDA )
+                  CALL ZHERK( 'Upper', 'Conjugate transpose', N-J-JB+1, 
+     $                        JB, -ONE, A( J, J+JB ), LDA, 
+     $                        ONE, A( J+JB, 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 ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+               IF( J+JB.LE.N ) THEN
+*
+*                Updating the trailing submatrix.
+*
+                 CALL ZTRSM( 'Right', 'Lower', 'Conjugate Transpose', 
+     $                       'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
+     $                       LDA, A( J+JB, J ), LDA )
+
+                 CALL ZHERK( 'Lower', 'No Transpose', N-J-JB+1, JB, 
+     $                       -ONE, A( J+JB, J ), LDA, 
+     $                       ONE, A( J+JB, J+JB ), 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/VARIANTS/cholesky/TOP/cpotrf.f b/SRC/VARIANTS/cholesky/TOP/cpotrf.f
new file mode 100644
index 00000000..54ae1bb9
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/cpotrf.f
@@ -0,0 +1,181 @@
+      SUBROUTINE CPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOTRF computes the Cholesky factorization of a real symmetric
+*  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 top-looking 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 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**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 ..
+      REAL               ONE
+      COMPLEX            CONE
+      PARAMETER          ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CPOTF2, CHERK, CTRSM, 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( 'CPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'CPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL CPOTF2( 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
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL CTRSM( 'Left', 'Upper', 'Conjugate Transpose', 
+     $                      'Non-unit', J-1, JB, CONE, A( 1, 1 ), LDA,
+     $                      A( 1, J ), LDA )
+
+               CALL CHERK( 'Upper', 'Conjugate Transpose', JB, J-1, 
+     $                      -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL CPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   10       CONTINUE
+*
+         ELSE
+*
+*           Compute the Cholesky factorization A = L*L'.
+*
+            DO 20 J = 1, N, NB
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL CTRSM( 'Right', 'Lower', 'Conjugate Transpose', 
+     $                     'Non-unit', JB, J-1, CONE, A( 1, 1 ), LDA,
+     $                     A( J, 1 ), LDA )
+
+               CALL CHERK( 'Lower', 'No Transpose', JB, J-1, 
+     $                     -ONE, A( J, 1 ), LDA, 
+     $                     ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL CPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   20       CONTINUE
+         END IF
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = INFO + J - 1
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of CPOTRF
+*
+      END
diff --git a/SRC/VARIANTS/cholesky/TOP/dpotrf.f b/SRC/VARIANTS/cholesky/TOP/dpotrf.f
new file mode 100644
index 00000000..8dd2c45b
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/dpotrf.f
@@ -0,0 +1,182 @@
+      SUBROUTINE DPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. 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 top-looking 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
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+     $                      J-1, JB, ONE, A( 1, 1 ), LDA,
+     $                      A( 1, J ), LDA )
+
+               CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
+     $                      A( 1, J ), LDA, 
+     $                      ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   10       CONTINUE
+*
+         ELSE
+*
+*           Compute the Cholesky factorization A = L*L'.
+*
+            DO 20 J = 1, N, NB
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+     $                     JB, J-1, ONE, A( 1, 1 ), LDA,
+     $                     A( J, 1 ), LDA )
+
+               CALL DSYRK( 'Lower', 'No Transpose', JB, J-1, 
+     $                     -ONE, A( J, 1 ), LDA, 
+     $                     ONE, A( J, J ), LDA )
+               
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   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/VARIANTS/cholesky/TOP/spotrf.f b/SRC/VARIANTS/cholesky/TOP/spotrf.f
new file mode 100644
index 00000000..08b41b48
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/spotrf.f
@@ -0,0 +1,181 @@
+      SUBROUTINE SPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOTRF 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 top-looking 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SPOTF2, SSYRK, STRSM, 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( 'SPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'SPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL SPOTF2( 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
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+     $                      J-1, JB, ONE, A( 1, 1 ), LDA,
+     $                      A( 1, J ), LDA )
+
+               CALL SSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
+     $                      A( 1, J ), LDA, 
+     $                      ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL SPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   10       CONTINUE
+*
+         ELSE
+*
+*           Compute the Cholesky factorization A = L*L'.
+*
+            DO 20 J = 1, N, NB
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL STRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+     $                     JB, J-1, ONE, A( 1, 1 ), LDA,
+     $                     A( J, 1 ), LDA )
+
+               CALL SSYRK( 'Lower', 'No Transpose', JB, J-1, 
+     $                     -ONE, A( J, 1 ), LDA, 
+     $                     ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL SPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   20       CONTINUE
+         END IF
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = INFO + J - 1
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of SPOTRF
+*
+      END
diff --git a/SRC/VARIANTS/cholesky/TOP/zpotrf.f b/SRC/VARIANTS/cholesky/TOP/zpotrf.f
new file mode 100644
index 00000000..4eae3d1b
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/zpotrf.f
@@ -0,0 +1,181 @@
+      SUBROUTINE ZPOTRF ( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOTRF computes the Cholesky factorization of a real symmetric
+*  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 top-looking 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 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**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           ZGEMM, ZPOTF2, ZHERK, ZTRSM, 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( '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
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL ZTRSM( 'Left', 'Upper', 'Conjugate Transpose', 
+     $                      'Non-unit', J-1, JB, CONE, A( 1, 1 ), LDA,
+     $                      A( 1, J ), LDA )
+
+               CALL ZHERK( 'Upper', 'Conjugate Transpose', JB, J-1, 
+     $                      -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   10       CONTINUE
+*
+         ELSE
+*
+*           Compute the Cholesky factorization A = L*L'.
+*
+            DO 20 J = 1, N, NB
+
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute the current block.
+*
+               CALL ZTRSM( 'Right', 'Lower', 'Conjugate Transpose', 
+     $                     'Non-unit', JB, J-1, CONE, A( 1, 1 ), LDA,
+     $                     A( J, 1 ), LDA )
+
+               CALL ZHERK( 'Lower', 'No Transpose', JB, J-1, 
+     $                     -ONE, A( J, 1 ), LDA, 
+     $                     ONE, A( J, J ), LDA )
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+
+   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/VARIANTS/lu/CR/cgetrf.f b/SRC/VARIANTS/lu/CR/cgetrf.f
new file mode 100644
index 00000000..7d6403e1
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/cgetrf.f
@@ -0,0 +1,165 @@
+      SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETRF 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 Crout 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CGETF2, CLASWP, CTRSM, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, MOD
+*     ..
+*     .. 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( 'CGETRF', -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, 'CGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL CGETF2( 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 )
+*
+*           Update current block.
+*
+            CALL CGEMM( 'No transpose', 'No transpose', 
+     $                 M-J+1, JB, J-1, -ONE, 
+     $                 A( J, 1 ), LDA, A( 1, J ), LDA, ONE,
+     $                 A( J, J ), LDA )
+            
+*
+*           Factor diagonal and subdiagonal blocks and test for exact
+*           singularity.
+*
+            CALL CGETF2( 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 column 1:J-1            
+*
+            CALL CLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF ( J+JB.LE.N ) THEN
+*            
+*              Apply interchanges to column J+JB:N            
+*
+               CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, 
+     $                     IPIV, 1 )
+*               
+               CALL CGEMM( 'No transpose', 'No transpose', 
+     $                    JB, N-J-JB+1, J-1, -ONE, 
+     $                    A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE,
+     $                    A( J, J+JB ), LDA )
+*
+*              Compute block row of U.
+*
+               CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    JB, N-J-JB+1, ONE, A( J, J ), LDA, 
+     $                    A( J, J+JB ), LDA )
+            END IF
+
+   20    CONTINUE
+
+      END IF
+      RETURN
+*
+*     End of CGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/CR/dgetrf.f b/SRC/VARIANTS/lu/CR/dgetrf.f
new file mode 100644
index 00000000..e1b4121e
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/dgetrf.f
@@ -0,0 +1,165 @@
+      SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. 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 Crout 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, MOD
+*     ..
+*     .. 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 )
+*
+*           Update current block.
+*
+            CALL DGEMM( 'No transpose', 'No transpose', 
+     $                 M-J+1, JB, J-1, -ONE, 
+     $                 A( J, 1 ), LDA, A( 1, J ), LDA, ONE,
+     $                 A( J, J ), LDA )
+            
+*
+*           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 column 1:J-1            
+*
+            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF ( J+JB.LE.N ) THEN
+*            
+*              Apply interchanges to column J+JB:N            
+*
+               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, 
+     $                     IPIV, 1 )
+*               
+               CALL DGEMM( 'No transpose', 'No transpose', 
+     $                    JB, N-J-JB+1, J-1, -ONE, 
+     $                    A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE,
+     $                    A( J, J+JB ), LDA )
+*
+*              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 )
+            END IF
+
+   20    CONTINUE
+
+      END IF
+      RETURN
+*
+*     End of DGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/CR/sgetrf.f b/SRC/VARIANTS/lu/CR/sgetrf.f
new file mode 100644
index 00000000..238ec119
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/sgetrf.f
@@ -0,0 +1,165 @@
+      SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETRF 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 Crout 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SGETF2, SLASWP, STRSM, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, MOD
+*     ..
+*     .. 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( 'SGETRF', -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, 'SGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL SGETF2( 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 )
+*
+*           Update current block.
+*
+            CALL SGEMM( 'No transpose', 'No transpose', 
+     $                 M-J+1, JB, J-1, -ONE, 
+     $                 A( J, 1 ), LDA, A( 1, J ), LDA, ONE,
+     $                 A( J, J ), LDA )
+            
+*
+*           Factor diagonal and subdiagonal blocks and test for exact
+*           singularity.
+*
+            CALL SGETF2( 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 column 1:J-1            
+*
+            CALL SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF ( J+JB.LE.N ) THEN
+*            
+*              Apply interchanges to column J+JB:N            
+*
+               CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, 
+     $                     IPIV, 1 )
+*               
+               CALL SGEMM( 'No transpose', 'No transpose', 
+     $                    JB, N-J-JB+1, J-1, -ONE, 
+     $                    A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE,
+     $                    A( J, J+JB ), LDA )
+*
+*              Compute block row of U.
+*
+               CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    JB, N-J-JB+1, ONE, A( J, J ), LDA, 
+     $                    A( J, J+JB ), LDA )
+            END IF
+
+   20    CONTINUE
+
+      END IF
+      RETURN
+*
+*     End of SGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/CR/zgetrf.f b/SRC/VARIANTS/lu/CR/zgetrf.f
new file mode 100644
index 00000000..2dafefbf
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/zgetrf.f
@@ -0,0 +1,165 @@
+      SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. 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 Crout 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           ZGEMM, ZGETF2, ZLASWP, ZTRSM, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, MOD
+*     ..
+*     .. 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 )
+*
+*           Update current block.
+*
+            CALL ZGEMM( 'No transpose', 'No transpose', 
+     $                 M-J+1, JB, J-1, -ONE, 
+     $                 A( J, 1 ), LDA, A( 1, J ), LDA, ONE,
+     $                 A( J, J ), LDA )
+            
+*
+*           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 column 1:J-1            
+*
+            CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF ( J+JB.LE.N ) THEN
+*            
+*              Apply interchanges to column J+JB:N            
+*
+               CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, 
+     $                     IPIV, 1 )
+*               
+               CALL ZGEMM( 'No transpose', 'No transpose', 
+     $                    JB, N-J-JB+1, J-1, -ONE, 
+     $                    A( J, 1 ), LDA, A( 1, J+JB ), LDA, ONE,
+     $                    A( J, J+JB ), LDA )
+*
+*              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 )
+            END IF
+
+   20    CONTINUE
+
+      END IF
+      RETURN
+*
+*     End of ZGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/LL/cgetrf.f b/SRC/VARIANTS/lu/LL/cgetrf.f
new file mode 100644
index 00000000..189362b0
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/cgetrf.f
@@ -0,0 +1,190 @@
+      SUBROUTINE CGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETRF 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 left-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 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            ONE
+      PARAMETER          ( ONE = (1.0E+0, 0.0E+0) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, K, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CGETF2, CLASWP, CTRSM, 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( 'CGETRF', -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, 'CGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL CGETF2( 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 )
+*
+*
+*           Update before factoring the current panel
+*
+            DO 30 K = 1, J-NB, NB
+*            
+*              Apply interchanges to rows K:K+NB-1.
+* 
+               CALL CLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    NB, JB, ONE, A( K, K ), LDA, 
+     $                    A( K, J ), LDA )
+*
+*              Update trailing submatrix.
+*
+               CALL CGEMM( 'No transpose', 'No transpose', 
+     $                    M-K-NB+1, JB, NB, -ONE, 
+     $                    A( K+NB, K ), LDA, A( K, J ), LDA, ONE,
+     $                    A( K+NB, J ), LDA )
+   30       CONTINUE
+*
+*           Factor diagonal and subdiagonal blocks and test for exact
+*           singularity.
+*
+            CALL CGETF2( 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
+*
+   20    CONTINUE
+
+*
+*        Apply interchanges to the left-overs
+*
+         DO 40 K = 1, MIN( M, N ), NB
+            CALL CLASWP( K-1, A( 1, 1 ), LDA, K, 
+     $                  MIN (K+NB-1, MIN ( M, N )), IPIV, 1 )
+   40    CONTINUE 
+*
+*        Apply update to the M+1:N columns when N > M
+*
+         IF ( N.GT.M ) THEN
+
+            CALL CLASWP( N-M, A(1, M+1), LDA, 1, M, IPIV, 1 )
+
+            DO 50 K = 1, M, NB
+
+               JB = MIN( M-K+1, NB )
+*
+               CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    JB, N-M, ONE, A( K, K ), LDA, 
+     $                    A( K, M+1 ), LDA )
+
+*     
+               IF ( K+NB.LE.M ) THEN
+                    CALL CGEMM( 'No transpose', 'No transpose', 
+     $                         M-K-NB+1, N-M, NB, -ONE, 
+     $                         A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE,
+     $                        A( K+NB, M+1 ), LDA )
+               END IF
+   50       CONTINUE  
+         END IF
+*
+      END IF
+      RETURN
+*
+*     End of CGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/LL/dgetrf.f b/SRC/VARIANTS/lu/LL/dgetrf.f
new file mode 100644
index 00000000..8231805c
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/dgetrf.f
@@ -0,0 +1,189 @@
+      SUBROUTINE DGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. 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 left-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, K, 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 )
+*
+*           Update before factoring the current panel
+*
+            DO 30 K = 1, J-NB, NB
+*            
+*              Apply interchanges to rows K:K+NB-1.
+* 
+               CALL DLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    NB, JB, ONE, A( K, K ), LDA, 
+     $                    A( K, J ), LDA )
+*
+*              Update trailing submatrix.
+*
+               CALL DGEMM( 'No transpose', 'No transpose', 
+     $                    M-K-NB+1, JB, NB, -ONE, 
+     $                    A( K+NB, K ), LDA, A( K, J ), LDA, ONE,
+     $                    A( K+NB, J ), LDA )
+   30       CONTINUE
+*
+*           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
+*
+   20    CONTINUE
+
+*
+*        Apply interchanges to the left-overs
+*
+         DO 40 K = 1, MIN( M, N ), NB
+            CALL DLASWP( K-1, A( 1, 1 ), LDA, K, 
+     $                  MIN (K+NB-1, MIN ( M, N )), IPIV, 1 )
+   40    CONTINUE 
+*
+*        Apply update to the M+1:N columns when N > M
+*
+         IF ( N.GT.M ) THEN
+
+            CALL DLASWP( N-M, A(1, M+1), LDA, 1, M, IPIV, 1 )
+
+            DO 50 K = 1, M, NB
+
+               JB = MIN( M-K+1, NB )
+*
+               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    JB, N-M, ONE, A( K, K ), LDA, 
+     $                    A( K, M+1 ), LDA )
+
+*     
+               IF ( K+NB.LE.M ) THEN
+                    CALL DGEMM( 'No transpose', 'No transpose', 
+     $                         M-K-NB+1, N-M, NB, -ONE, 
+     $                         A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE,
+     $                        A( K+NB, M+1 ), LDA )
+               END IF
+   50       CONTINUE  
+         END IF
+*
+      END IF
+      RETURN
+*
+*     End of DGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/LL/sgetrf.f b/SRC/VARIANTS/lu/LL/sgetrf.f
new file mode 100644
index 00000000..856c1a7e
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/sgetrf.f
@@ -0,0 +1,190 @@
+      SUBROUTINE SGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETRF 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 left-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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, K, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SGETF2, SLASWP, STRSM, 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( 'SGETRF', -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, 'SGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL SGETF2( 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 )
+*
+*
+*           Update before factoring the current panel
+*
+            DO 30 K = 1, J-NB, NB
+*            
+*              Apply interchanges to rows K:K+NB-1.
+* 
+               CALL SLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    NB, JB, ONE, A( K, K ), LDA, 
+     $                    A( K, J ), LDA )
+*
+*              Update trailing submatrix.
+*
+               CALL SGEMM( 'No transpose', 'No transpose', 
+     $                    M-K-NB+1, JB, NB, -ONE, 
+     $                    A( K+NB, K ), LDA, A( K, J ), LDA, ONE,
+     $                    A( K+NB, J ), LDA )
+   30       CONTINUE
+*
+*           Factor diagonal and subdiagonal blocks and test for exact
+*           singularity.
+*
+            CALL SGETF2( 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
+*
+   20    CONTINUE
+
+*
+*        Apply interchanges to the left-overs
+*
+         DO 40 K = 1, MIN( M, N ), NB
+            CALL SLASWP( K-1, A( 1, 1 ), LDA, K, 
+     $                  MIN (K+NB-1, MIN ( M, N )), IPIV, 1 )
+   40    CONTINUE 
+*
+*        Apply update to the M+1:N columns when N > M
+*
+         IF ( N.GT.M ) THEN
+
+            CALL SLASWP( N-M, A(1, M+1), LDA, 1, M, IPIV, 1 )
+
+            DO 50 K = 1, M, NB
+
+               JB = MIN( M-K+1, NB )
+*
+               CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    JB, N-M, ONE, A( K, K ), LDA, 
+     $                    A( K, M+1 ), LDA )
+
+*     
+               IF ( K+NB.LE.M ) THEN
+                    CALL SGEMM( 'No transpose', 'No transpose', 
+     $                         M-K-NB+1, N-M, NB, -ONE, 
+     $                         A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE,
+     $                        A( K+NB, M+1 ), LDA )
+               END IF
+   50       CONTINUE  
+         END IF
+*
+      END IF
+      RETURN
+*
+*     End of SGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/LL/zgetrf.f b/SRC/VARIANTS/lu/LL/zgetrf.f
new file mode 100644
index 00000000..a6f9c0ff
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/zgetrf.f
@@ -0,0 +1,190 @@
+      SUBROUTINE ZGETRF ( M, N, A, LDA, IPIV, INFO)
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. 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 left-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, K, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMM, ZGETF2, ZLASWP, ZTRSM, 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( '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 )
+*
+*
+*           Update before factoring the current panel
+*
+            DO 30 K = 1, J-NB, NB
+*            
+*              Apply interchanges to rows K:K+NB-1.
+* 
+               CALL ZLASWP( JB, A(1, J), LDA, K, K+NB-1, IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    NB, JB, ONE, A( K, K ), LDA, 
+     $                    A( K, J ), LDA )
+*
+*              Update trailing submatrix.
+*
+               CALL ZGEMM( 'No transpose', 'No transpose', 
+     $                    M-K-NB+1, JB, NB, -ONE, 
+     $                    A( K+NB, K ), LDA, A( K, J ), LDA, ONE,
+     $                    A( K+NB, J ), LDA )
+   30       CONTINUE
+*
+*           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
+*
+   20    CONTINUE
+
+*
+*        Apply interchanges to the left-overs
+*
+         DO 40 K = 1, MIN( M, N ), NB
+            CALL ZLASWP( K-1, A( 1, 1 ), LDA, K, 
+     $                  MIN (K+NB-1, MIN ( M, N )), IPIV, 1 )
+   40    CONTINUE 
+*
+*        Apply update to the M+1:N columns when N > M
+*
+         IF ( N.GT.M ) THEN
+
+            CALL ZLASWP( N-M, A(1, M+1), LDA, 1, M, IPIV, 1 )
+
+            DO 50 K = 1, M, NB
+
+               JB = MIN( M-K+1, NB )
+*
+               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                    JB, N-M, ONE, A( K, K ), LDA, 
+     $                    A( K, M+1 ), LDA )
+
+*     
+               IF ( K+NB.LE.M ) THEN
+                    CALL ZGEMM( 'No transpose', 'No transpose', 
+     $                         M-K-NB+1, N-M, NB, -ONE, 
+     $                         A( K+NB, K ), LDA, A( K, M+1 ), LDA, ONE,
+     $                        A( K+NB, M+1 ), LDA )
+               END IF
+   50       CONTINUE  
+         END IF
+*
+      END IF
+      RETURN
+*
+*     End of ZGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/REC/cgetrf.f b/SRC/VARIANTS/lu/REC/cgetrf.f
new file mode 100644
index 00000000..d8a8a90b
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/cgetrf.f
@@ -0,0 +1,224 @@
+      SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK routine (version 3.X) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     May 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETRF 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 code implements an iterative version of Sivan Toledo's recursive
+*  LU algorithm[1].  For square matrices, this iterative versions should
+*  be within a factor of two of the optimum number of memory transfers.
+*
+*  The pattern is as follows, with the large blocks of U being updated
+*  in one call to DTRSM, and the dotted lines denoting sections that
+*  have had all pending permutations applied:
+*
+*   1 2 3 4 5 6 7 8
+*  +-+-+---+-------+------
+*  | |1|   |       |
+*  |.+-+ 2 |       |
+*  | | |   |       |
+*  |.|.+-+-+   4   |
+*  | | | |1|       |
+*  | | |.+-+       |
+*  | | | | |       |
+*  |.|.|.|.+-+-+---+  8
+*  | | | | | |1|   |
+*  | | | | |.+-+ 2 |
+*  | | | | | | |   |
+*  | | | | |.|.+-+-+
+*  | | | | | | | |1|
+*  | | | | | | |.+-+
+*  | | | | | | | | |
+*  |.|.|.|.|.|.|.|.+-----
+*  | | | | | | | | |
+*
+*  The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in
+*  the binary expansion of the current column.  Each Schur update is
+*  applied as soon as the necessary portion of U is available.
+*
+*  [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
+*  Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+*  1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+*
+*  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 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            ONE, NEGONE
+      REAL               ZERO
+      PARAMETER          ( ONE = (1.0E+0, 0.0E+0) )
+      PARAMETER          ( NEGONE = (-1.0E+0, 0.0E+0) )
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               SFMIN, PIVMAG
+      COMPLEX            TMP
+      INTEGER            I, J, JP, NSTEP, NTOPIV, NPIVED, KAHEAD
+      INTEGER            KSTART, IPIVSTART, JPIVSTART, KCOLS
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      INTEGER            ICAMAX
+      LOGICAL            SISNAN
+      EXTERNAL           SLAMCH, ICAMAX, SISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTRSM, CSCAL, XERBLA, CLASWP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, IAND, ABS
+*     ..
+*     .. 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( 'CGETRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Compute machine safe minimum
+*
+      SFMIN = SLAMCH( 'S' )
+*
+      NSTEP = MIN( M, N )
+      DO J = 1, NSTEP
+         KAHEAD = IAND( J, -J )
+         KSTART = J + 1 - KAHEAD
+         KCOLS = MIN( KAHEAD, M-J )
+*
+*        Find pivot.
+*
+         JP = J - 1 + ICAMAX( M-J+1, A( J, J ), 1 )
+         IPIV( J ) = JP
+
+!        Permute just this column.
+         IF (JP .NE. J) THEN
+            TMP = A( J, J )
+            A( J, J ) = A( JP, J )
+            A( JP, J ) = TMP
+         END IF
+
+!        Apply pending permutations to L
+         NTOPIV = 1
+         IPIVSTART = J
+         JPIVSTART = J - NTOPIV
+         DO WHILE ( NTOPIV .LT. KAHEAD )
+            CALL CLASWP( NTOPIV, A( 1, JPIVSTART ), LDA, IPIVSTART, J,
+     $           IPIV, 1 )
+            IPIVSTART = IPIVSTART - NTOPIV;
+            NTOPIV = NTOPIV * 2;
+            JPIVSTART = JPIVSTART - NTOPIV;
+         END DO
+
+!        Permute U block to match L
+         CALL CLASWP( KCOLS, A( 1,J+1 ), LDA, KSTART, J, IPIV, 1 )
+
+!        Factor the current column
+         PIVMAG = ABS( A( J, J ) )
+         IF( PIVMAG.NE.ZERO .AND. .NOT.SISNAN( PIVMAG ) ) THEN
+               IF( PIVMAG .GE. SFMIN ) THEN
+                  CALL CSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+               ELSE
+                 DO I = 1, M-J
+                    A( J+I, J ) = A( J+I, J ) / A( J, J )
+                 END DO
+               END IF
+         ELSE IF( PIVMAG .EQ. ZERO .AND. INFO .EQ. 0 ) THEN
+            INFO = J
+         END IF
+
+!        Solve for U block.
+         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', KAHEAD,
+     $        KCOLS, ONE, A( KSTART, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA )
+!        Schur complement.
+         CALL CGEMM( 'No transpose', 'No transpose', M-J,
+     $        KCOLS, KAHEAD, NEGONE, A( J+1, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA, ONE, A( J+1, J+1 ), LDA )
+      END DO
+
+!     Handle pivot permutations on the way out of the recursion
+      NPIVED = IAND( NSTEP, -NSTEP )
+      J = NSTEP - NPIVED
+      DO WHILE ( J .GT. 0 )
+         NTOPIV = IAND( J, -J )
+         CALL CLASWP( NTOPIV, A( 1, J-NTOPIV+1 ), LDA, J+1, NSTEP,
+     $        IPIV, 1 )
+         J = J - NTOPIV
+      END DO
+
+!     If short and wide, handle the rest of the columns.
+      IF ( M .LT. N ) THEN
+         CALL CLASWP( N-M, A( 1, M+KCOLS+1 ), LDA, 1, M, IPIV, 1 )
+         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', M,
+     $        N-M, ONE, A, LDA, A( 1,M+KCOLS+1 ), LDA )
+      END IF
+
+      RETURN
+*
+*     End of CGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/REC/dgetrf.f b/SRC/VARIANTS/lu/REC/dgetrf.f
new file mode 100644
index 00000000..f8c2caf1
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/dgetrf.f
@@ -0,0 +1,220 @@
+      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK routine (version 3.X) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     May 2008
+*
+*     .. 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 code implements an iterative version of Sivan Toledo's recursive
+*  LU algorithm[1].  For square matrices, this iterative versions should
+*  be within a factor of two of the optimum number of memory transfers.
+*
+*  The pattern is as follows, with the large blocks of U being updated
+*  in one call to DTRSM, and the dotted lines denoting sections that
+*  have had all pending permutations applied:
+*
+*   1 2 3 4 5 6 7 8
+*  +-+-+---+-------+------
+*  | |1|   |       |
+*  |.+-+ 2 |       |
+*  | | |   |       |
+*  |.|.+-+-+   4   |
+*  | | | |1|       |
+*  | | |.+-+       |
+*  | | | | |       |
+*  |.|.|.|.+-+-+---+  8
+*  | | | | | |1|   |
+*  | | | | |.+-+ 2 |
+*  | | | | | | |   |
+*  | | | | |.|.+-+-+
+*  | | | | | | | |1|
+*  | | | | | | |.+-+
+*  | | | | | | | | |
+*  |.|.|.|.|.|.|.|.+-----
+*  | | | | | | | | |
+*
+*  The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in
+*  the binary expansion of the current column.  Each Schur update is
+*  applied as soon as the necessary portion of U is available.
+*
+*  [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
+*  Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+*  1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+*
+*  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, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+      PARAMETER          ( NEGONE = -1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   SFMIN, TMP
+      INTEGER            I, J, JP, NSTEP, NTOPIV, NPIVED, KAHEAD
+      INTEGER            KSTART, IPIVSTART, JPIVSTART, KCOLS
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      INTEGER            IDAMAX
+      LOGICAL            DISNAN
+      EXTERNAL           DLAMCH, IDAMAX, DISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTRSM, DSCAL, XERBLA, DLASWP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, IAND
+*     ..
+*     .. 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
+*
+*     Compute machine safe minimum
+*
+      SFMIN = DLAMCH( 'S' )
+*
+      NSTEP = MIN( M, N )
+      DO J = 1, NSTEP
+         KAHEAD = IAND( J, -J )
+         KSTART = J + 1 - KAHEAD
+         KCOLS = MIN( KAHEAD, M-J )
+*
+*        Find pivot.
+*
+         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
+         IPIV( J ) = JP
+
+!        Permute just this column.
+         IF (JP .NE. J) THEN
+            TMP = A( J, J )
+            A( J, J ) = A( JP, J )
+            A( JP, J ) = TMP
+         END IF
+
+!        Apply pending permutations to L
+         NTOPIV = 1
+         IPIVSTART = J
+         JPIVSTART = J - NTOPIV
+         DO WHILE ( NTOPIV .LT. KAHEAD )
+            CALL DLASWP( NTOPIV, A( 1, JPIVSTART ), LDA, IPIVSTART, J,
+     $           IPIV, 1 )
+            IPIVSTART = IPIVSTART - NTOPIV;
+            NTOPIV = NTOPIV * 2;
+            JPIVSTART = JPIVSTART - NTOPIV;
+         END DO
+
+!        Permute U block to match L
+         CALL DLASWP( KCOLS, A( 1,J+1 ), LDA, KSTART, J, IPIV, 1 )
+
+!        Factor the current column
+         IF( A( J, J ).NE.ZERO .AND. .NOT.DISNAN( A( J, J ) ) ) THEN
+               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
+                  CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+               ELSE
+                 DO I = 1, M-J
+                    A( J+I, J ) = A( J+I, J ) / A( J, J )
+                 END DO
+               END IF
+         ELSE IF( A( J,J ) .EQ. ZERO .AND. INFO .EQ. 0 ) THEN
+            INFO = J
+         END IF
+
+!        Solve for U block.
+         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', KAHEAD,
+     $        KCOLS, ONE, A( KSTART, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA )
+!        Schur complement.
+         CALL DGEMM( 'No transpose', 'No transpose', M-J,
+     $        KCOLS, KAHEAD, NEGONE, A( J+1, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA, ONE, A( J+1, J+1 ), LDA )
+      END DO
+
+!     Handle pivot permutations on the way out of the recursion
+      NPIVED = IAND( NSTEP, -NSTEP )
+      J = NSTEP - NPIVED
+      DO WHILE ( J .GT. 0 )
+         NTOPIV = IAND( J, -J )
+         CALL DLASWP( NTOPIV, A( 1, J-NTOPIV+1 ), LDA, J+1, NSTEP,
+     $        IPIV, 1 )
+         J = J - NTOPIV
+      END DO
+
+!     If short and wide, handle the rest of the columns.
+      IF ( M .LT. N ) THEN
+         CALL DLASWP( N-M, A( 1, M+KCOLS+1 ), LDA, 1, M, IPIV, 1 )
+         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', M,
+     $        N-M, ONE, A, LDA, A( 1,M+KCOLS+1 ), LDA )
+      END IF
+
+      RETURN
+*
+*     End of DGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/REC/sgetrf.f b/SRC/VARIANTS/lu/REC/sgetrf.f
new file mode 100644
index 00000000..1890f987
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/sgetrf.f
@@ -0,0 +1,220 @@
+      SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK routine (version 3.X) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     May 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETRF 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 code implements an iterative version of Sivan Toledo's recursive
+*  LU algorithm[1].  For square matrices, this iterative versions should
+*  be within a factor of two of the optimum number of memory transfers.
+*
+*  The pattern is as follows, with the large blocks of U being updated
+*  in one call to STRSM, and the dotted lines denoting sections that
+*  have had all pending permutations applied:
+*
+*   1 2 3 4 5 6 7 8
+*  +-+-+---+-------+------
+*  | |1|   |       |
+*  |.+-+ 2 |       |
+*  | | |   |       |
+*  |.|.+-+-+   4   |
+*  | | | |1|       |
+*  | | |.+-+       |
+*  | | | | |       |
+*  |.|.|.|.+-+-+---+  8
+*  | | | | | |1|   |
+*  | | | | |.+-+ 2 |
+*  | | | | | | |   |
+*  | | | | |.|.+-+-+
+*  | | | | | | | |1|
+*  | | | | | | |.+-+
+*  | | | | | | | | |
+*  |.|.|.|.|.|.|.|.+-----
+*  | | | | | | | | |
+*
+*  The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in
+*  the binary expansion of the current column.  Each Schur update is
+*  applied as soon as the necessary portion of U is available.
+*
+*  [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
+*  Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+*  1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+*
+*  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) REAL 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 ..
+      REAL               ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+      PARAMETER          ( NEGONE = -1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               SFMIN, TMP
+      INTEGER            I, J, JP, NSTEP, NTOPIV, NPIVED, KAHEAD
+      INTEGER            KSTART, IPIVSTART, JPIVSTART, KCOLS
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      INTEGER            ISAMAX
+      LOGICAL            SISNAN
+      EXTERNAL           SLAMCH, ISAMAX, SISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STRSM, SSCAL, XERBLA, SLASWP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, IAND
+*     ..
+*     .. 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( 'SGETRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Compute machine safe minimum
+*
+      SFMIN = SLAMCH( 'S' )
+*
+      NSTEP = MIN( M, N )
+      DO J = 1, NSTEP
+         KAHEAD = IAND( J, -J )
+         KSTART = J + 1 - KAHEAD
+         KCOLS = MIN( KAHEAD, M-J )
+*
+*        Find pivot.
+*
+         JP = J - 1 + ISAMAX( M-J+1, A( J, J ), 1 )
+         IPIV( J ) = JP
+
+!        Permute just this column.
+         IF (JP .NE. J) THEN
+            TMP = A( J, J )
+            A( J, J ) = A( JP, J )
+            A( JP, J ) = TMP
+         END IF
+
+!        Apply pending permutations to L
+         NTOPIV = 1
+         IPIVSTART = J
+         JPIVSTART = J - NTOPIV
+         DO WHILE ( NTOPIV .LT. KAHEAD )
+            CALL SLASWP( NTOPIV, A( 1, JPIVSTART ), LDA, IPIVSTART, J,
+     $           IPIV, 1 )
+            IPIVSTART = IPIVSTART - NTOPIV;
+            NTOPIV = NTOPIV * 2;
+            JPIVSTART = JPIVSTART - NTOPIV;
+         END DO
+
+!        Permute U block to match L
+         CALL SLASWP( KCOLS, A( 1,J+1 ), LDA, KSTART, J, IPIV, 1 )
+
+!        Factor the current column
+         IF( A( J, J ).NE.ZERO .AND. .NOT.SISNAN( A( J, J ) ) ) THEN
+               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
+                  CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+               ELSE
+                 DO I = 1, M-J
+                    A( J+I, J ) = A( J+I, J ) / A( J, J )
+                 END DO
+               END IF
+         ELSE IF( A( J,J ) .EQ. ZERO .AND. INFO .EQ. 0 ) THEN
+            INFO = J
+         END IF
+
+!        Solve for U block.
+         CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', KAHEAD,
+     $        KCOLS, ONE, A( KSTART, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA )
+!        Schur complement.
+         CALL SGEMM( 'No transpose', 'No transpose', M-J,
+     $        KCOLS, KAHEAD, NEGONE, A( J+1, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA, ONE, A( J+1, J+1 ), LDA )
+      END DO
+
+!     Handle pivot permutations on the way out of the recursion
+      NPIVED = IAND( NSTEP, -NSTEP )
+      J = NSTEP - NPIVED
+      DO WHILE ( J .GT. 0 )
+         NTOPIV = IAND( J, -J )
+         CALL SLASWP( NTOPIV, A( 1, J-NTOPIV+1 ), LDA, J+1, NSTEP,
+     $        IPIV, 1 )
+         J = J - NTOPIV
+      END DO
+
+!     If short and wide, handle the rest of the columns.
+      IF ( M .LT. N ) THEN
+         CALL SLASWP( N-M, A( 1, M+KCOLS+1 ), LDA, 1, M, IPIV, 1 )
+         CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', M,
+     $        N-M, ONE, A, LDA, A( 1,M+KCOLS+1 ), LDA )
+      END IF
+
+      RETURN
+*
+*     End of SGETRF
+*
+      END
diff --git a/SRC/VARIANTS/lu/REC/zgetrf.f b/SRC/VARIANTS/lu/REC/zgetrf.f
new file mode 100644
index 00000000..e7b75b00
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/zgetrf.f
@@ -0,0 +1,224 @@
+      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK routine (version 3.X) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     May 2008
+*
+*     .. 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 code implements an iterative version of Sivan Toledo's recursive
+*  LU algorithm[1].  For square matrices, this iterative versions should
+*  be within a factor of two of the optimum number of memory transfers.
+*
+*  The pattern is as follows, with the large blocks of U being updated
+*  in one call to DTRSM, and the dotted lines denoting sections that
+*  have had all pending permutations applied:
+*
+*   1 2 3 4 5 6 7 8
+*  +-+-+---+-------+------
+*  | |1|   |       |
+*  |.+-+ 2 |       |
+*  | | |   |       |
+*  |.|.+-+-+   4   |
+*  | | | |1|       |
+*  | | |.+-+       |
+*  | | | | |       |
+*  |.|.|.|.+-+-+---+  8
+*  | | | | | |1|   |
+*  | | | | |.+-+ 2 |
+*  | | | | | | |   |
+*  | | | | |.|.+-+-+
+*  | | | | | | | |1|
+*  | | | | | | |.+-+
+*  | | | | | | | | |
+*  |.|.|.|.|.|.|.|.+-----
+*  | | | | | | | | |
+*
+*  The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in
+*  the binary expansion of the current column.  Each Schur update is
+*  applied as soon as the necessary portion of U is available.
+*
+*  [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
+*  Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+*  1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+*
+*  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, NEGONE
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ONE = (1.0D+0, 0.0D+0) )
+      PARAMETER          ( NEGONE = (-1.0D+0, 0.0D+0) )
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   SFMIN, PIVMAG
+      COMPLEX*16         TMP
+      INTEGER            I, J, JP, NSTEP, NTOPIV, NPIVED, KAHEAD
+      INTEGER            KSTART, IPIVSTART, JPIVSTART, KCOLS
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      INTEGER            IZAMAX
+      LOGICAL            DISNAN
+      EXTERNAL           DLAMCH, IZAMAX, DISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZTRSM, ZSCAL, XERBLA, ZLASWP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, IAND, ABS
+*     ..
+*     .. 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
+*
+*     Compute machine safe minimum
+*
+      SFMIN = DLAMCH( 'S' )
+*
+      NSTEP = MIN( M, N )
+      DO J = 1, NSTEP
+         KAHEAD = IAND( J, -J )
+         KSTART = J + 1 - KAHEAD
+         KCOLS = MIN( KAHEAD, M-J )
+*
+*        Find pivot.
+*
+         JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
+         IPIV( J ) = JP
+
+!        Permute just this column.
+         IF (JP .NE. J) THEN
+            TMP = A( J, J )
+            A( J, J ) = A( JP, J )
+            A( JP, J ) = TMP
+         END IF
+
+!        Apply pending permutations to L
+         NTOPIV = 1
+         IPIVSTART = J
+         JPIVSTART = J - NTOPIV
+         DO WHILE ( NTOPIV .LT. KAHEAD )
+            CALL ZLASWP( NTOPIV, A( 1, JPIVSTART ), LDA, IPIVSTART, J,
+     $           IPIV, 1 )
+            IPIVSTART = IPIVSTART - NTOPIV;
+            NTOPIV = NTOPIV * 2;
+            JPIVSTART = JPIVSTART - NTOPIV;
+         END DO
+
+!        Permute U block to match L
+         CALL ZLASWP( KCOLS, A( 1,J+1 ), LDA, KSTART, J, IPIV, 1 )
+
+!        Factor the current column
+         PIVMAG = ABS( A( J, J ) )
+         IF( PIVMAG.NE.ZERO .AND. .NOT.DISNAN( PIVMAG ) ) THEN
+               IF( PIVMAG .GE. SFMIN ) THEN
+                  CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+               ELSE
+                 DO I = 1, M-J
+                    A( J+I, J ) = A( J+I, J ) / A( J, J )
+                 END DO
+               END IF
+         ELSE IF( PIVMAG .EQ. ZERO .AND. INFO .EQ. 0 ) THEN
+            INFO = J
+         END IF
+
+!        Solve for U block.
+         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', KAHEAD,
+     $        KCOLS, ONE, A( KSTART, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA )
+!        Schur complement.
+         CALL ZGEMM( 'No transpose', 'No transpose', M-J,
+     $        KCOLS, KAHEAD, NEGONE, A( J+1, KSTART ), LDA,
+     $        A( KSTART, J+1 ), LDA, ONE, A( J+1, J+1 ), LDA )
+      END DO
+
+!     Handle pivot permutations on the way out of the recursion
+      NPIVED = IAND( NSTEP, -NSTEP )
+      J = NSTEP - NPIVED
+      DO WHILE ( J .GT. 0 )
+         NTOPIV = IAND( J, -J )
+         CALL ZLASWP( NTOPIV, A( 1, J-NTOPIV+1 ), LDA, J+1, NSTEP,
+     $        IPIV, 1 )
+         J = J - NTOPIV
+      END DO
+
+!     If short and wide, handle the rest of the columns.
+      IF ( M .LT. N ) THEN
+         CALL ZLASWP( N-M, A( 1, M+KCOLS+1 ), LDA, 1, M, IPIV, 1 )
+         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', M,
+     $        N-M, ONE, A, LDA, A( 1,M+KCOLS+1 ), LDA )
+      END IF
+
+      RETURN
+*
+*     End of ZGETRF
+*
+      END
diff --git a/SRC/VARIANTS/qr/LL/cgeqrf.f b/SRC/VARIANTS/qr/LL/cgeqrf.f
new file mode 100644
index 00000000..413bc90c
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/cgeqrf.f
@@ -0,0 +1,343 @@
+      SUBROUTINE CGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEQRF computes a QR factorization of a real M-by-N matrix A:
+*  A = Q * R.
+*
+*  This is the left-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 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) COMPLEX array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX 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 dimension can be divided into three parts.
+*
+*          1) The part for the triangular factor T. If the very last T is not bigger 
+*             than any of the rest, then this part is NB x ceiling(K/NB), otherwise, 
+*             NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T              
+*
+*          2) The part for the very last T when T is bigger than any of the rest T. 
+*             The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB,
+*             where K = min(M,N), NX is calculated by
+*                   NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) )
+*
+*          3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB)
+*
+*          So LWORK = part1 + part2 + part3
+*
+*          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, J, K, LWKOPT, NB,
+     $                   NBMIN, NX, LBWORK, NT, LLWORK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQR2, CLARFB, CLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SCEIL
+      EXTERNAL           ILAENV, SCEIL
+*     ..
+*     .. Executable Statements ..
+
+      INFO = 0
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      K = MIN( M, N )
+      NB = ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )
+
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) )
+      END IF
+*
+*     Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.:
+*
+*            NB=3     2NB=6       K=10
+*            |        |           |    
+*      1--2--3--4--5--6--7--8--9--10
+*                  |     \________/
+*               K-NX=5      NT=4
+*
+*     So here 4 x 4 is the last T stored in the workspace
+*
+      NT = K-SCEIL(REAL(K-NX)/REAL(NB))*NB
+
+*
+*     optimal workspace = space for dlarfb + space for normal T's + space for the last T
+*
+      LLWORK = MAX (MAX((N-M)*K, (N-M)*NB), MAX(K*NB, NB*NB))
+      LLWORK = SCEIL(REAL(LLWORK)/REAL(NB))
+
+      IF ( NT.GT.NB ) THEN
+
+          LBWORK = K-NT 
+*
+*         Optimal workspace for dlarfb = MAX(1,N)*NT
+*
+          LWKOPT = (LBWORK+LLWORK)*NB
+          WORK( 1 ) = (LWKOPT+NT*NT)
+
+      ELSE
+
+          LBWORK = SCEIL(REAL(K)/REAL(NB))*NB
+          LWKOPT = (LBWORK+LLWORK-NB)*NB 
+          WORK( 1 ) = LWKOPT
+
+      END IF
+
+*
+*     Test the input arguments
+*
+      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( 'CGEQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            IF ( NT.LE.NB ) THEN
+                IWS = (LBWORK+LLWORK-NB)*NB
+            ELSE
+                IWS = (LBWORK+LLWORK)*NB+NT*NT
+            END IF
+
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               IF ( NT.LE.NB ) THEN
+                    NB = LWORK / (LLWORK+(LBWORK-NB))
+               ELSE
+                    NB = (LWORK-NT*NT)/(LBWORK+LLWORK)
+               END IF
+
+               NBMIN = MAX( 2, ILAENV( 2, 'CGEQRF', ' ', 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 )
+*
+*           Update the current column using old T's
+*
+            DO 20 J = 1, I - NB, NB
+*
+*              Apply H' to A(J:M,I:I+IB-1) from the left
+*
+               CALL CLARFB( 'Left', 'Transpose', 'Forward',
+     $                      'Columnwise', M-J+1, IB, NB,
+     $                      A( J, J ), LDA, WORK(J), LBWORK, 
+     $                      A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                      IB)
+
+20          CONTINUE   
+*
+*           Compute the QR factorization of the current block
+*           A(I:M,I:I+IB-1)
+*
+            CALL CGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), 
+     $                        WORK(LBWORK*NB+NT*NT+1), 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 CLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+     $                      A( I, I ), LDA, TAU( I ), 
+     $                      WORK(I), LBWORK )
+*
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K ) THEN
+         
+         IF ( I .NE. 1 )   THEN
+
+             DO 30 J = 1, I - NB, NB
+*
+*                Apply H' to A(J:M,I:K) from the left
+*
+                 CALL CLARFB( 'Left', 'Transpose', 'Forward',
+     $                       'Columnwise', M-J+1, K-I+1, NB,
+     $                       A( J, J ), LDA, WORK(J), LBWORK, 
+     $                       A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                       K-I+1)
+30           CONTINUE   
+
+             CALL CGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), 
+     $                   WORK(LBWORK*NB+NT*NT+1),IINFO )
+
+         ELSE
+*
+*        Use unblocked code to factor the last or only block.
+*
+         CALL CGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), 
+     $               WORK,IINFO )
+
+         END IF
+      END IF
+
+
+*
+*     Apply update to the column M+1:N when N > M
+*
+      IF ( M.LT.N .AND. I.NE.1) THEN
+*
+*         Form the last triangular factor of the block reflector
+*         H = H(i) H(i+1) . . . H(i+ib-1)
+*
+          IF ( NT .LE. NB ) THEN
+               CALL CLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), WORK(I), LBWORK )
+          ELSE
+               CALL CLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), 
+     $                     WORK(LBWORK*NB+1), NT )
+          END IF
+
+*
+*         Apply H' to A(1:M,M+1:N) from the left
+*
+          DO 40 J = 1, K-NX, NB
+
+               IB = MIN( K-J+1, NB )
+
+               CALL CLARFB( 'Left', 'Transpose', 'Forward',
+     $                     'Columnwise', M-J+1, N-M, IB,
+     $                     A( J, J ), LDA, WORK(J), LBWORK, 
+     $                     A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                     N-M)
+
+40       CONTINUE   
+         
+         IF ( NT.LE.NB ) THEN
+             CALL CLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, WORK(J), LBWORK, 
+     $                   A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         ELSE 
+             CALL CLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, 
+     $                   WORK(LBWORK*NB+1), 
+     $                   NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         END IF
+          
+      END IF
+
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of CGEQRF
+*
+      END
diff --git a/SRC/VARIANTS/qr/LL/dgeqrf.f b/SRC/VARIANTS/qr/LL/dgeqrf.f
new file mode 100644
index 00000000..728ea1b8
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/dgeqrf.f
@@ -0,0 +1,344 @@
+      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..
+*     March 2008
+*
+*     .. 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.
+*
+*  This is the left-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 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. The dimension can be divided into three parts.
+*
+*          1) The part for the triangular factor T. If the very last T is not bigger 
+*             than any of the rest, then this part is NB x ceiling(K/NB), otherwise, 
+*             NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T              
+*
+*          2) The part for the very last T when T is bigger than any of the rest T. 
+*             The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB,
+*             where K = min(M,N), NX is calculated by
+*                   NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) )
+*
+*          3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB)
+*
+*          So LWORK = part1 + part2 + part3
+*
+*          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, J, K, LWKOPT, NB,
+     $                   NBMIN, NX, LBWORK, NT, LLWORK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQR2, DLARFB, DLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SCEIL
+      EXTERNAL           ILAENV, SCEIL
+*     ..
+*     .. Executable Statements ..
+
+      INFO = 0
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      K = MIN( M, N )
+      NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+
+      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 ) )
+      END IF
+*
+*     Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.:
+*
+*            NB=3     2NB=6       K=10
+*            |        |           |    
+*      1--2--3--4--5--6--7--8--9--10
+*                  |     \________/
+*               K-NX=5      NT=4
+*
+*     So here 4 x 4 is the last T stored in the workspace
+*
+      NT = K-SCEIL(REAL(K-NX)/REAL(NB))*NB
+
+*
+*     optimal workspace = space for dlarfb + space for normal T's + space for the last T
+*
+      LLWORK = MAX (MAX((N-M)*K, (N-M)*NB), MAX(K*NB, NB*NB))
+      LLWORK = SCEIL(REAL(LLWORK)/REAL(NB))
+
+      IF ( NT.GT.NB ) THEN
+
+          LBWORK = K-NT 
+*
+*         Optimal workspace for dlarfb = MAX(1,N)*NT
+*
+          LWKOPT = (LBWORK+LLWORK)*NB
+          WORK( 1 ) = (LWKOPT+NT*NT)
+
+      ELSE
+
+          LBWORK = SCEIL(REAL(K)/REAL(NB))*NB
+          LWKOPT = (LBWORK+LLWORK-NB)*NB 
+          WORK( 1 ) = LWKOPT
+
+      END IF
+
+*
+*     Test the input arguments
+*
+      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
+*
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            IF ( NT.LE.NB ) THEN
+                IWS = (LBWORK+LLWORK-NB)*NB
+            ELSE
+                IWS = (LBWORK+LLWORK)*NB+NT*NT
+            END IF
+
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               IF ( NT.LE.NB ) THEN
+                    NB = LWORK / (LLWORK+(LBWORK-NB))
+               ELSE
+                    NB = (LWORK-NT*NT)/(LBWORK+LLWORK)
+               END IF
+
+               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 )
+*
+*           Update the current column using old T's
+*
+            DO 20 J = 1, I - NB, NB
+*
+*              Apply H' to A(J:M,I:I+IB-1) from the left
+*
+               CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                      'Columnwise', M-J+1, IB, NB,
+     $                      A( J, J ), LDA, WORK(J), LBWORK, 
+     $                      A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                      IB)
+
+20          CONTINUE   
+*
+*           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(LBWORK*NB+NT*NT+1), 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(I), LBWORK )
+*
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K ) THEN
+         
+         IF ( I .NE. 1 )   THEN
+
+             DO 30 J = 1, I - NB, NB
+*
+*                Apply H' to A(J:M,I:K) from the left
+*
+                 CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                       'Columnwise', M-J+1, K-I+1, NB,
+     $                       A( J, J ), LDA, WORK(J), LBWORK, 
+     $                       A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                       K-I+1)
+30           CONTINUE   
+
+             CALL DGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), 
+     $                   WORK(LBWORK*NB+NT*NT+1),IINFO )
+
+         ELSE
+*
+*        Use unblocked code to factor the last or only block.
+*
+         CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), 
+     $               WORK,IINFO )
+
+         END IF
+      END IF
+
+
+*
+*     Apply update to the column M+1:N when N > M
+*
+      IF ( M.LT.N .AND. I.NE.1) THEN
+*
+*         Form the last triangular factor of the block reflector
+*         H = H(i) H(i+1) . . . H(i+ib-1)
+*
+          IF ( NT .LE. NB ) THEN
+               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), WORK(I), LBWORK )
+          ELSE
+               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), 
+     $                     WORK(LBWORK*NB+1), NT )
+          END IF
+
+*
+*         Apply H' to A(1:M,M+1:N) from the left
+*
+          DO 40 J = 1, K-NX, NB
+
+               IB = MIN( K-J+1, NB )
+
+               CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                     'Columnwise', M-J+1, N-M, IB,
+     $                     A( J, J ), LDA, WORK(J), LBWORK, 
+     $                     A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                     N-M)
+
+40       CONTINUE   
+         
+         IF ( NT.LE.NB ) THEN
+             CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, WORK(J), LBWORK, 
+     $                   A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         ELSE 
+             CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, 
+     $                   WORK(LBWORK*NB+1), 
+     $                   NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         END IF
+          
+      END IF
+
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGEQRF
+*
+      END
+
diff --git a/SRC/VARIANTS/qr/LL/sceil.f b/SRC/VARIANTS/qr/LL/sceil.f
new file mode 100644
index 00000000..70c5c5cf
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/sceil.f
@@ -0,0 +1,28 @@
+      REAL FUNCTION SCEIL( A )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     June 2008
+*
+*     .. Scalar Arguments ..*
+      REAL A
+*     ..
+*
+*  =====================================================================
+*
+*     .. Intrinsic Functions ..
+	      INTRINSIC          INT
+*     ..
+*     .. Executable Statements ..*
+*      
+      IF (A-INT(A).EQ.0) THEN
+          SCEIL = A
+      ELSE IF (A.GT.0) THEN
+          SCEIL = INT(A)+1;
+      ELSE
+          SCEIL = INT(A)
+      END IF
+
+      RETURN
+*
+      END
diff --git a/SRC/VARIANTS/qr/LL/sgeqrf.f b/SRC/VARIANTS/qr/LL/sgeqrf.f
new file mode 100644
index 00000000..fef6379b
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/sgeqrf.f
@@ -0,0 +1,343 @@
+      SUBROUTINE SGEQRF ( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEQRF computes a QR factorization of a real M-by-N matrix A:
+*  A = Q * R.
+*
+*  This is the left-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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) REAL 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 dimension can be divided into three parts.
+*
+*          1) The part for the triangular factor T. If the very last T is not bigger 
+*             than any of the rest, then this part is NB x ceiling(K/NB), otherwise, 
+*             NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T              
+*
+*          2) The part for the very last T when T is bigger than any of the rest T. 
+*             The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB,
+*             where K = min(M,N), NX is calculated by
+*                   NX = MAX( 0, ILAENV( 3, 'SGEQRF', ' ', M, N, -1, -1 ) )
+*
+*          3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB)
+*
+*          So LWORK = part1 + part2 + part3
+*
+*          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, J, K, LWKOPT, NB,
+     $                   NBMIN, NX, LBWORK, NT, LLWORK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQR2, SLARFB, SLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SCEIL
+      EXTERNAL           ILAENV, SCEIL
+*     ..
+*     .. Executable Statements ..
+
+      INFO = 0
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      K = MIN( M, N )
+      NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'SGEQRF', ' ', M, N, -1, -1 ) )
+      END IF
+*
+*     Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.:
+*
+*            NB=3     2NB=6       K=10
+*            |        |           |    
+*      1--2--3--4--5--6--7--8--9--10
+*                  |     \________/
+*               K-NX=5      NT=4
+*
+*     So here 4 x 4 is the last T stored in the workspace
+*
+      NT = K-SCEIL(REAL(K-NX)/REAL(NB))*NB
+
+*
+*     optimal workspace = space for dlarfb + space for normal T's + space for the last T
+*
+      LLWORK = MAX (MAX((N-M)*K, (N-M)*NB), MAX(K*NB, NB*NB))
+      LLWORK = SCEIL(REAL(LLWORK)/REAL(NB))
+
+      IF ( NT.GT.NB ) THEN
+
+          LBWORK = K-NT 
+*
+*         Optimal workspace for dlarfb = MAX(1,N)*NT
+*
+          LWKOPT = (LBWORK+LLWORK)*NB
+          WORK( 1 ) = (LWKOPT+NT*NT)
+
+      ELSE
+
+          LBWORK = SCEIL(REAL(K)/REAL(NB))*NB
+          LWKOPT = (LBWORK+LLWORK-NB)*NB 
+          WORK( 1 ) = LWKOPT
+
+      END IF
+
+*
+*     Test the input arguments
+*
+      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( 'SGEQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            IF ( NT.LE.NB ) THEN
+                IWS = (LBWORK+LLWORK-NB)*NB
+            ELSE
+                IWS = (LBWORK+LLWORK)*NB+NT*NT
+            END IF
+
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               IF ( NT.LE.NB ) THEN
+                    NB = LWORK / (LLWORK+(LBWORK-NB))
+               ELSE
+                    NB = (LWORK-NT*NT)/(LBWORK+LLWORK)
+               END IF
+
+               NBMIN = MAX( 2, ILAENV( 2, 'SGEQRF', ' ', 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 )
+*
+*           Update the current column using old T's
+*
+            DO 20 J = 1, I - NB, NB
+*
+*              Apply H' to A(J:M,I:I+IB-1) from the left
+*
+               CALL SLARFB( 'Left', 'Transpose', 'Forward',
+     $                      'Columnwise', M-J+1, IB, NB,
+     $                      A( J, J ), LDA, WORK(J), LBWORK, 
+     $                      A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                      IB)
+
+20          CONTINUE   
+*
+*           Compute the QR factorization of the current block
+*           A(I:M,I:I+IB-1)
+*
+            CALL SGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), 
+     $                        WORK(LBWORK*NB+NT*NT+1), 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 SLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+     $                      A( I, I ), LDA, TAU( I ), 
+     $                      WORK(I), LBWORK )
+*
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K ) THEN
+         
+         IF ( I .NE. 1 )   THEN
+
+             DO 30 J = 1, I - NB, NB
+*
+*                Apply H' to A(J:M,I:K) from the left
+*
+                 CALL SLARFB( 'Left', 'Transpose', 'Forward',
+     $                       'Columnwise', M-J+1, K-I+1, NB,
+     $                       A( J, J ), LDA, WORK(J), LBWORK, 
+     $                       A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                       K-I+1)
+30           CONTINUE   
+
+             CALL SGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), 
+     $                   WORK(LBWORK*NB+NT*NT+1),IINFO )
+
+         ELSE
+*
+*        Use unblocked code to factor the last or only block.
+*
+         CALL SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), 
+     $               WORK,IINFO )
+
+         END IF
+      END IF
+
+
+*
+*     Apply update to the column M+1:N when N > M
+*
+      IF ( M.LT.N .AND. I.NE.1) THEN
+*
+*         Form the last triangular factor of the block reflector
+*         H = H(i) H(i+1) . . . H(i+ib-1)
+*
+          IF ( NT .LE. NB ) THEN
+               CALL SLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), WORK(I), LBWORK )
+          ELSE
+               CALL SLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), 
+     $                     WORK(LBWORK*NB+1), NT )
+          END IF
+
+*
+*         Apply H' to A(1:M,M+1:N) from the left
+*
+          DO 40 J = 1, K-NX, NB
+
+               IB = MIN( K-J+1, NB )
+
+               CALL SLARFB( 'Left', 'Transpose', 'Forward',
+     $                     'Columnwise', M-J+1, N-M, IB,
+     $                     A( J, J ), LDA, WORK(J), LBWORK, 
+     $                     A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                     N-M)
+
+40       CONTINUE   
+         
+         IF ( NT.LE.NB ) THEN
+             CALL SLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, WORK(J), LBWORK, 
+     $                   A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         ELSE 
+             CALL SLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, 
+     $                   WORK(LBWORK*NB+1), 
+     $                   NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         END IF
+          
+      END IF
+
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of SGEQRF
+*
+      END
diff --git a/SRC/VARIANTS/qr/LL/zgeqrf.f b/SRC/VARIANTS/qr/LL/zgeqrf.f
new file mode 100644
index 00000000..cf5e093e
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/zgeqrf.f
@@ -0,0 +1,343 @@
+      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..
+*     March 2008
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEQRF computes a QR factorization of a real M-by-N matrix A:
+*  A = Q * R.
+*
+*  This is the left-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 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) 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. The dimension can be divided into three parts.
+*
+*          1) The part for the triangular factor T. If the very last T is not bigger 
+*             than any of the rest, then this part is NB x ceiling(K/NB), otherwise, 
+*             NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T              
+*
+*          2) The part for the very last T when T is bigger than any of the rest T. 
+*             The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB,
+*             where K = min(M,N), NX is calculated by
+*                   NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) )
+*
+*          3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB)
+*
+*          So LWORK = part1 + part2 + part3
+*
+*          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, J, K, LWKOPT, NB,
+     $                   NBMIN, NX, LBWORK, NT, LLWORK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEQR2, ZLARFB, ZLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SCEIL
+      EXTERNAL           ILAENV, SCEIL
+*     ..
+*     .. Executable Statements ..
+
+      INFO = 0
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      K = MIN( M, N )
+      NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+
+      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 ) )
+      END IF
+*
+*     Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.:
+*
+*            NB=3     2NB=6       K=10
+*            |        |           |    
+*      1--2--3--4--5--6--7--8--9--10
+*                  |     \________/
+*               K-NX=5      NT=4
+*
+*     So here 4 x 4 is the last T stored in the workspace
+*
+      NT = K-SCEIL(REAL(K-NX)/REAL(NB))*NB
+
+*
+*     optimal workspace = space for dlarfb + space for normal T's + space for the last T
+*
+      LLWORK = MAX (MAX((N-M)*K, (N-M)*NB), MAX(K*NB, NB*NB))
+      LLWORK = SCEIL(REAL(LLWORK)/REAL(NB))
+
+      IF ( NT.GT.NB ) THEN
+
+          LBWORK = K-NT 
+*
+*         Optimal workspace for dlarfb = MAX(1,N)*NT
+*
+          LWKOPT = (LBWORK+LLWORK)*NB
+          WORK( 1 ) = (LWKOPT+NT*NT)
+
+      ELSE
+
+          LBWORK = SCEIL(REAL(K)/REAL(NB))*NB
+          LWKOPT = (LBWORK+LLWORK-NB)*NB 
+          WORK( 1 ) = LWKOPT
+
+      END IF
+
+*
+*     Test the input arguments
+*
+      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
+*
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            IF ( NT.LE.NB ) THEN
+                IWS = (LBWORK+LLWORK-NB)*NB
+            ELSE
+                IWS = (LBWORK+LLWORK)*NB+NT*NT
+            END IF
+
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               IF ( NT.LE.NB ) THEN
+                    NB = LWORK / (LLWORK+(LBWORK-NB))
+               ELSE
+                    NB = (LWORK-NT*NT)/(LBWORK+LLWORK)
+               END IF
+
+               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 )
+*
+*           Update the current column using old T's
+*
+            DO 20 J = 1, I - NB, NB
+*
+*              Apply H' to A(J:M,I:I+IB-1) from the left
+*
+               CALL ZLARFB( 'Left', 'Transpose', 'Forward',
+     $                      'Columnwise', M-J+1, IB, NB,
+     $                      A( J, J ), LDA, WORK(J), LBWORK, 
+     $                      A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                      IB)
+
+20          CONTINUE   
+*
+*           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(LBWORK*NB+NT*NT+1), 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(I), LBWORK )
+*
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K ) THEN
+         
+         IF ( I .NE. 1 )   THEN
+
+             DO 30 J = 1, I - NB, NB
+*
+*                Apply H' to A(J:M,I:K) from the left
+*
+                 CALL ZLARFB( 'Left', 'Transpose', 'Forward',
+     $                       'Columnwise', M-J+1, K-I+1, NB,
+     $                       A( J, J ), LDA, WORK(J), LBWORK, 
+     $                       A( J, I ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                       K-I+1)
+30           CONTINUE   
+
+             CALL ZGEQR2( M-I+1, K-I+1, A( I, I ), LDA, TAU( I ), 
+     $                   WORK(LBWORK*NB+NT*NT+1),IINFO )
+
+         ELSE
+*
+*        Use unblocked code to factor the last or only block.
+*
+         CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), 
+     $               WORK,IINFO )
+
+         END IF
+      END IF
+
+
+*
+*     Apply update to the column M+1:N when N > M
+*
+      IF ( M.LT.N .AND. I.NE.1) THEN
+*
+*         Form the last triangular factor of the block reflector
+*         H = H(i) H(i+1) . . . H(i+ib-1)
+*
+          IF ( NT .LE. NB ) THEN
+               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), WORK(I), LBWORK )
+          ELSE
+               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, K-I+1,
+     $                     A( I, I ), LDA, TAU( I ), 
+     $                     WORK(LBWORK*NB+1), NT )
+          END IF
+
+*
+*         Apply H' to A(1:M,M+1:N) from the left
+*
+          DO 40 J = 1, K-NX, NB
+
+               IB = MIN( K-J+1, NB )
+
+               CALL ZLARFB( 'Left', 'Transpose', 'Forward',
+     $                     'Columnwise', M-J+1, N-M, IB,
+     $                     A( J, J ), LDA, WORK(J), LBWORK, 
+     $                     A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                     N-M)
+
+40       CONTINUE   
+         
+         IF ( NT.LE.NB ) THEN
+             CALL ZLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, WORK(J), LBWORK, 
+     $                   A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         ELSE 
+             CALL ZLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise', M-J+1, N-M, K-J+1,
+     $                   A( J, J ), LDA, 
+     $                   WORK(LBWORK*NB+1), 
+     $                   NT, A( J, M+1 ), LDA, WORK(LBWORK*NB+NT*NT+1),
+     $                   N-M)
+         END IF
+          
+      END IF
+
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGEQRF
+*
+      END
diff --git a/SRC/cbdsqr.f b/SRC/cbdsqr.f
new file mode 100644
index 00000000..cc03e132
--- /dev/null
+++ b/SRC/cbdsqr.f
@@ -0,0 +1,742 @@
+      SUBROUTINE CBDSQR( 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 ..
+      REAL               D( * ), E( * ), RWORK( * )
+      COMPLEX            C( LDC, * ), U( LDU, * ), VT( LDVT, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CBDSQR 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 CGEBRD, 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) REAL 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) REAL 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 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 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 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) REAL 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  REAL, 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               NEGONE
+      PARAMETER          ( NEGONE = -1.0E0 )
+      REAL               HNDRTH
+      PARAMETER          ( HNDRTH = 0.01E0 )
+      REAL               TEN
+      PARAMETER          ( TEN = 10.0E0 )
+      REAL               HNDRD
+      PARAMETER          ( HNDRD = 100.0E0 )
+      REAL               MEIGTH
+      PARAMETER          ( MEIGTH = -0.125E0 )
+      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
+      REAL               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
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASR, CSROT, CSSCAL, CSWAP, SLARTG, SLAS2,
+     $                   SLASQ1, SLASV2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, 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( 'CBDSQR', -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 SLASQ1( N, D, E, RWORK, INFO )
+         RETURN
+      END IF
+*
+      NM1 = N - 1
+      NM12 = NM1 + NM1
+      NM13 = NM12 + NM1
+      IDIR = 0
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'Epsilon' )
+      UNFL = SLAMCH( '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 SLARTG( 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 CLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ),
+     $                  U, LDU )
+         IF( NCC.GT.0 )
+     $      CALL CLASR( '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( REAL( 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 SLASV2( 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 CSROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT,
+     $                  COSR, SINR )
+         IF( NRU.GT.0 )
+     $      CALL CSROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
+         IF( NCC.GT.0 )
+     $      CALL CSROT( 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 SLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
+         ELSE
+            SLL = ABS( D( M ) )
+            CALL SLAS2( 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 SLARTG( D( I )*CS, E( I ), CS, SN, R )
+               IF( I.GT.LL )
+     $            E( I-1 ) = OLDSN*R
+               CALL SLARTG( 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 CLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
+     $                     RWORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL CLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL CLASR( '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 SLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+               IF( I.LT.M )
+     $            E( I ) = OLDSN*R
+               CALL SLARTG( 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 CLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL CLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
+     $                     RWORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL CLASR( '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 SLARTG( 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 SLARTG( 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 CLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
+     $                     RWORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL CLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL CLASR( '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 SLARTG( 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 SLARTG( 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 CLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL CLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
+     $                     RWORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL CLASR( '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 CSSCAL( 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 CSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
+     $                     LDVT )
+            IF( NRU.GT.0 )
+     $         CALL CSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL CSWAP( 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 CBDSQR
+*
+      END
diff --git a/SRC/cgbbrd.f b/SRC/cgbbrd.f
new file mode 100644
index 00000000..fc57ee9d
--- /dev/null
+++ b/SRC/cgbbrd.f
@@ -0,0 +1,465 @@
+      SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
+     $                   LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E( * ), RWORK( * )
+      COMPLEX            AB( LDAB, * ), C( LDC, * ), PT( LDPT, * ),
+     $                   Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBBRD reduces a complex general m-by-n band matrix A to real upper
+*  bidiagonal form B by a unitary transformation: Q' * A * P = B.
+*
+*  The routine computes B, and optionally forms Q or P', or computes
+*  Q'*C for a given matrix C.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          Specifies whether or not the matrices Q and P' are to be
+*          formed.
+*          = 'N': do not form Q or P';
+*          = 'Q': form Q only;
+*          = 'P': form P' only;
+*          = 'B': form both.
+*
+*  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.
+*
+*  NCC     (input) INTEGER
+*          The number of columns of the matrix C.  NCC >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals of the matrix A. KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals of the matrix A. KU >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the m-by-n band matrix A, stored in rows 1 to
+*          KL+KU+1. The j-th column of A is stored in the j-th column of
+*          the array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*          On exit, A is overwritten by values generated during the
+*          reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A. LDAB >= KL+KU+1.
+*
+*  D       (output) REAL array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B.
+*
+*  E       (output) REAL array, dimension (min(M,N)-1)
+*          The superdiagonal elements of the bidiagonal matrix B.
+*
+*  Q       (output) COMPLEX array, dimension (LDQ,M)
+*          If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
+*          If VECT = 'N' or 'P', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
+*
+*  PT      (output) COMPLEX array, dimension (LDPT,N)
+*          If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
+*          If VECT = 'N' or 'Q', the array PT is not referenced.
+*
+*  LDPT    (input) INTEGER
+*          The leading dimension of the array PT.
+*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
+*
+*  C       (input/output) COMPLEX array, dimension (LDC,NCC)
+*          On entry, an m-by-ncc matrix C.
+*          On exit, C is overwritten by Q'*C.
+*          C is not referenced if NCC = 0.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C.
+*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
+*
+*  WORK    (workspace) COMPLEX array, dimension (max(M,N))
+*
+*  RWORK   (workspace) REAL array, dimension (max(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTB, WANTC, WANTPT, WANTQ
+      INTEGER            I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
+     $                   KUN, L, MINMN, ML, ML0, MU, MU0, NR, NRT
+      REAL               ABST, RC
+      COMPLEX            RA, RB, RS, T
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARGV, CLARTG, CLARTV, CLASET, CROT, CSCAL,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTB = LSAME( VECT, 'B' )
+      WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
+      WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
+      WANTC = NCC.GT.0
+      KLU1 = KL + KU + 1
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KLU1 ) THEN
+         INFO = -8
+      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
+         INFO = -12
+      ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBBRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and P' to the unit matrix, if needed
+*
+      IF( WANTQ )
+     $   CALL CLASET( 'Full', M, M, CZERO, CONE, Q, LDQ )
+      IF( WANTPT )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, PT, LDPT )
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      MINMN = MIN( M, N )
+*
+      IF( KL+KU.GT.1 ) THEN
+*
+*        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
+*        first to lower bidiagonal form and then transform to upper
+*        bidiagonal
+*
+         IF( KU.GT.0 ) THEN
+            ML0 = 1
+            MU0 = 2
+         ELSE
+            ML0 = 2
+            MU0 = 1
+         END IF
+*
+*        Wherever possible, plane rotations are generated and applied in
+*        vector operations of length NR over the index set J1:J2:KLU1.
+*
+*        The complex sines of the plane rotations are stored in WORK,
+*        and the real cosines in RWORK.
+*
+         KLM = MIN( M-1, KL )
+         KUN = MIN( N-1, KU )
+         KB = KLM + KUN
+         KB1 = KB + 1
+         INCA = KB1*LDAB
+         NR = 0
+         J1 = KLM + 2
+         J2 = 1 - KUN
+*
+         DO 90 I = 1, MINMN
+*
+*           Reduce i-th column and i-th row of matrix to bidiagonal form
+*
+            ML = KLM + 1
+            MU = KUN + 1
+            DO 80 KK = 1, KB
+               J1 = J1 + KB
+               J2 = J2 + KB
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been created below the band
+*
+               IF( NR.GT.0 )
+     $            CALL CLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
+     $                         WORK( J1 ), KB1, RWORK( J1 ), KB1 )
+*
+*              apply plane rotations from the left
+*
+               DO 10 L = 1, KB
+                  IF( J2-KLM+L-1.GT.N ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL CLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
+     $                            AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
+     $                            RWORK( J1 ), WORK( J1 ), KB1 )
+   10          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  IF( ML.LE.M-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i+ml-1,i)
+*                    within the band, and apply rotation from the left
+*
+                     CALL CLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
+     $                            RWORK( I+ML-1 ), WORK( I+ML-1 ), RA )
+                     AB( KU+ML-1, I ) = RA
+                     IF( I.LT.N )
+     $                  CALL CROT( MIN( KU+ML-2, N-I ),
+     $                             AB( KU+ML-2, I+1 ), LDAB-1,
+     $                             AB( KU+ML-1, I+1 ), LDAB-1,
+     $                             RWORK( I+ML-1 ), WORK( I+ML-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTQ ) THEN
+*
+*                 accumulate product of plane rotations in Q
+*
+                  DO 20 J = J1, J2, KB1
+                     CALL CROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                          RWORK( J ), CONJG( WORK( J ) ) )
+   20             CONTINUE
+               END IF
+*
+               IF( WANTC ) THEN
+*
+*                 apply plane rotations to C
+*
+                  DO 30 J = J1, J2, KB1
+                     CALL CROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
+     $                          RWORK( J ), WORK( J ) )
+   30             CONTINUE
+               END IF
+*
+               IF( J2+KUN.GT.N ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 40 J = J1, J2, KB1
+*
+*                 create nonzero element a(j-1,j+ku) above the band
+*                 and store it in WORK(n+1:2*n)
+*
+                  WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
+                  AB( 1, J+KUN ) = RWORK( J )*AB( 1, J+KUN )
+   40          CONTINUE
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been generated above the band
+*
+               IF( NR.GT.0 )
+     $            CALL CLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
+     $                         WORK( J1+KUN ), KB1, RWORK( J1+KUN ),
+     $                         KB1 )
+*
+*              apply plane rotations from the right
+*
+               DO 50 L = 1, KB
+                  IF( J2+L-1.GT.M ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL CLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
+     $                            AB( L, J1+KUN ), INCA,
+     $                            RWORK( J1+KUN ), WORK( J1+KUN ), KB1 )
+   50          CONTINUE
+*
+               IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
+                  IF( MU.LE.N-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i,i+mu-1)
+*                    within the band, and apply rotation from the right
+*
+                     CALL CLARTG( AB( KU-MU+3, I+MU-2 ),
+     $                            AB( KU-MU+2, I+MU-1 ),
+     $                            RWORK( I+MU-1 ), WORK( I+MU-1 ), RA )
+                     AB( KU-MU+3, I+MU-2 ) = RA
+                     CALL CROT( MIN( KL+MU-2, M-I ),
+     $                          AB( KU-MU+4, I+MU-2 ), 1,
+     $                          AB( KU-MU+3, I+MU-1 ), 1,
+     $                          RWORK( I+MU-1 ), WORK( I+MU-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTPT ) THEN
+*
+*                 accumulate product of plane rotations in P'
+*
+                  DO 60 J = J1, J2, KB1
+                     CALL CROT( N, PT( J+KUN-1, 1 ), LDPT,
+     $                          PT( J+KUN, 1 ), LDPT, RWORK( J+KUN ),
+     $                          CONJG( WORK( J+KUN ) ) )
+   60             CONTINUE
+               END IF
+*
+               IF( J2+KB.GT.M ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 70 J = J1, J2, KB1
+*
+*                 create nonzero element a(j+kl+ku,j+ku-1) below the
+*                 band and store it in WORK(1:n)
+*
+                  WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
+                  AB( KLU1, J+KUN ) = RWORK( J+KUN )*AB( KLU1, J+KUN )
+   70          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  ML = ML - 1
+               ELSE
+                  MU = MU - 1
+               END IF
+   80       CONTINUE
+   90    CONTINUE
+      END IF
+*
+      IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
+*
+*        A has been reduced to complex lower bidiagonal form
+*
+*        Transform lower bidiagonal form to upper bidiagonal by applying
+*        plane rotations from the left, overwriting superdiagonal
+*        elements on subdiagonal elements
+*
+         DO 100 I = 1, MIN( M-1, N )
+            CALL CLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
+            AB( 1, I ) = RA
+            IF( I.LT.N ) THEN
+               AB( 2, I ) = RS*AB( 1, I+1 )
+               AB( 1, I+1 ) = RC*AB( 1, I+1 )
+            END IF
+            IF( WANTQ )
+     $         CALL CROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC,
+     $                    CONJG( RS ) )
+            IF( WANTC )
+     $         CALL CROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
+     $                    RS )
+  100    CONTINUE
+      ELSE
+*
+*        A has been reduced to complex upper bidiagonal form or is
+*        diagonal
+*
+         IF( KU.GT.0 .AND. M.LT.N ) THEN
+*
+*           Annihilate a(m,m+1) by applying plane rotations from the
+*           right
+*
+            RB = AB( KU, M+1 )
+            DO 110 I = M, 1, -1
+               CALL CLARTG( AB( KU+1, I ), RB, RC, RS, RA )
+               AB( KU+1, I ) = RA
+               IF( I.GT.1 ) THEN
+                  RB = -CONJG( RS )*AB( KU, I )
+                  AB( KU, I ) = RC*AB( KU, I )
+               END IF
+               IF( WANTPT )
+     $            CALL CROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
+     $                       RC, CONJG( RS ) )
+  110       CONTINUE
+         END IF
+      END IF
+*
+*     Make diagonal and superdiagonal elements real, storing them in D
+*     and E
+*
+      T = AB( KU+1, 1 )
+      DO 120 I = 1, MINMN
+         ABST = ABS( T )
+         D( I ) = ABST
+         IF( ABST.NE.ZERO ) THEN
+            T = T / ABST
+         ELSE
+            T = CONE
+         END IF
+         IF( WANTQ )
+     $      CALL CSCAL( M, T, Q( 1, I ), 1 )
+         IF( WANTC )
+     $      CALL CSCAL( NCC, CONJG( T ), C( I, 1 ), LDC )
+         IF( I.LT.MINMN ) THEN
+            IF( KU.EQ.0 .AND. KL.EQ.0 ) THEN
+               E( I ) = ZERO
+               T = AB( 1, I+1 )
+            ELSE
+               IF( KU.EQ.0 ) THEN
+                  T = AB( 2, I )*CONJG( T )
+               ELSE
+                  T = AB( KU, I+1 )*CONJG( T )
+               END IF
+               ABST = ABS( T )
+               E( I ) = ABST
+               IF( ABST.NE.ZERO ) THEN
+                  T = T / ABST
+               ELSE
+                  T = CONE
+               END IF
+               IF( WANTPT )
+     $            CALL CSCAL( N, T, PT( I+1, 1 ), LDPT )
+               T = AB( KU+1, I+1 )*CONJG( T )
+            END IF
+         END IF
+  120 CONTINUE
+      RETURN
+*
+*     End of CGBBRD
+*
+      END
diff --git a/SRC/cgbcon.f b/SRC/cgbcon.f
new file mode 100644
index 00000000..c171763c
--- /dev/null
+++ b/SRC/cgbcon.f
@@ -0,0 +1,234 @@
+      SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, 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 CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, KL, KU, LDAB, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               RWORK( * )
+      COMPLEX            AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBCON estimates the reciprocal of the condition number of a complex
+*  general band matrix A, in either the 1-norm or the infinity-norm,
+*  using the LU factorization computed by CGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by CGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= N, row i of the matrix was
+*          interchanged with row IPIV(i).
+*
+*  ANORM   (input) REAL
+*          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) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LNOTI, ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, J, JP, KASE, KASE1, KD, LM
+      REAL               AINVNM, SCALE, SMLNUM
+      COMPLEX            T, ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, ICAMAX, SLAMCH, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CLACN2, CLATBS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( 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( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the norm of inv(A).
+*
+      AINVNM = ZERO
+      NORMIN = 'N'
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KD = KL + KU + 1
+      LNOTI = KL.GT.0
+      KASE = 0
+   10 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            IF( LNOTI ) THEN
+               DO 20 J = 1, N - 1
+                  LM = MIN( KL, N-J )
+                  JP = IPIV( J )
+                  T = WORK( JP )
+                  IF( JP.NE.J ) THEN
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+                  CALL CAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
+   20          CONTINUE
+            END IF
+*
+*           Multiply by inv(U).
+*
+            CALL CLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KL+KU, AB, LDAB, WORK, SCALE, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL CLATBS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, KL+KU, AB, LDAB, WORK, SCALE, RWORK,
+     $                   INFO )
+*
+*           Multiply by inv(L').
+*
+            IF( LNOTI ) THEN
+               DO 30 J = N - 1, 1, -1
+                  LM = MIN( KL, N-J )
+                  WORK( J ) = WORK( J ) - CDOTC( LM, AB( KD+1, J ), 1,
+     $                        WORK( J+1 ), 1 )
+                  JP = IPIV( J )
+                  IF( JP.NE.J ) THEN
+                     T = WORK( JP )
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+   30          CONTINUE
+            END IF
+         END IF
+*
+*        Divide X by 1/SCALE if doing so will not cause overflow.
+*
+         NORMIN = 'Y'
+         IF( SCALE.NE.ONE ) THEN
+            IX = ICAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 40
+            CALL CSRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of CGBCON
+*
+      END
diff --git a/SRC/cgbequ.f b/SRC/cgbequ.f
new file mode 100644
index 00000000..4b6aae82
--- /dev/null
+++ b/SRC/cgbequ.f
@@ -0,0 +1,247 @@
+      SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, 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, KL, KU, LDAB, M, N
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), R( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBEQU computes row and column scalings intended to equilibrate an
+*  M-by-N band matrix A and reduce its condition number.  R returns the
+*  row scale factors and C the column scale factors, chosen to try to
+*  make the largest element in each row and column of the matrix B with
+*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+*  number and BIGNUM = largest safe number.  Use of these scaling
+*  factors is not guaranteed to reduce the condition number of A but
+*  works well in practice.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  R       (output) REAL array, dimension (M)
+*          If INFO = 0, or INFO > M, R contains the row scale factors
+*          for A.
+*
+*  C       (output) REAL array, dimension (N)
+*          If INFO = 0, C contains the column scale factors for A.
+*
+*  ROWCND  (output) REAL
+*          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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, KD
+      REAL               BIGNUM, RCMAX, RCMIN, SMLNUM
+      COMPLEX            ZDUM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBEQU', -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 = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+*     Compute row scale factors.
+*
+      DO 10 I = 1, M
+         R( I ) = ZERO
+   10 CONTINUE
+*
+*     Find the maximum element in each row.
+*
+      KD = KU + 1
+      DO 30 J = 1, N
+         DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            R( I ) = MAX( R( I ), CABS1( AB( KD+I-J, J ) ) )
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 40 I = 1, M
+         RCMAX = MAX( RCMAX, R( I ) )
+         RCMIN = MIN( RCMIN, R( I ) )
+   40 CONTINUE
+      AMAX = RCMAX
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 50 I = 1, M
+            IF( R( I ).EQ.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   50    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 60 I = 1, M
+            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+   60    CONTINUE
+*
+*        Compute ROWCND = min(R(I)) / max(R(I))
+*
+         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+*     Compute column scale factors
+*
+      DO 70 J = 1, N
+         C( J ) = ZERO
+   70 CONTINUE
+*
+*     Find the maximum element in each column,
+*     assuming the row scaling computed above.
+*
+      KD = KU + 1
+      DO 90 J = 1, N
+         DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            C( J ) = MAX( C( J ), CABS1( AB( KD+I-J, J ) )*R( I ) )
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 100 J = 1, N
+         RCMIN = MIN( RCMIN, C( J ) )
+         RCMAX = MAX( RCMAX, C( J ) )
+  100 CONTINUE
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 110 J = 1, N
+            IF( C( J ).EQ.ZERO ) THEN
+               INFO = M + J
+               RETURN
+            END IF
+  110    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 120 J = 1, N
+            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+  120    CONTINUE
+*
+*        Compute COLCND = min(C(J)) / max(C(J))
+*
+         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+      RETURN
+*
+*     End of CGBEQU
+*
+      END
diff --git a/SRC/cgbrfs.f b/SRC/cgbrfs.f
new file mode 100644
index 00000000..d15ca585
--- /dev/null
+++ b/SRC/cgbrfs.f
@@ -0,0 +1,365 @@
+      SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is banded, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The original band matrix A, stored in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input) COMPLEX array, dimension (LDAFB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by CGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from CGBTRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CGBTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGBMV, CGBTRS, CLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -9
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( KL+KU+2, N+1 )
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( '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 CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CGBMV( TRANS, N, N, KL, KU, -CONE, AB, LDAB, X( 1, J ), 1,
+     $               CONE, WORK, 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
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               KK = KU + 1 - K
+               XK = CABS1( X( K, J ) )
+               DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  RWORK( I ) = RWORK( I ) + CABS1( AB( KK+I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               KK = KU + 1 - K
+               DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  S = S + CABS1( AB( KK+I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, WORK, N,
+     $                   INFO )
+            CALL CAXPY( N, CONE, WORK, 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 CLACN2 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( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL CGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CGBTRS( TRANSN, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CGBRFS
+*
+      END
diff --git a/SRC/cgbsv.f b/SRC/cgbsv.f
new file mode 100644
index 00000000..6168f2fb
--- /dev/null
+++ b/SRC/cgbsv.f
@@ -0,0 +1,142 @@
+      SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBSV computes the solution to a complex system of linear equations
+*  A * X = B, where A is a band matrix of order N with KL subdiagonals
+*  and KU superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  The LU decomposition with partial pivoting and row interchanges is
+*  used to factor A as A = L * U, where L is a product of permutation
+*  and unit lower triangular matrices with KL subdiagonals, and U is
+*  upper triangular with KL+KU superdiagonals.  The factored form of A
+*  is then used to solve the system of equations A * X = B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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) COMPLEX 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).
+*
+*  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 the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           CGBTRF, CGBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of the band matrix A.
+*
+      CALL CGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
+     $                B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of CGBSV
+*
+      END
diff --git a/SRC/cgbsvx.f b/SRC/cgbsvx.f
new file mode 100644
index 00000000..c9024e96
--- /dev/null
+++ b/SRC/cgbsvx.f
@@ -0,0 +1,517 @@
+      SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
+     $                   LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, RWORK, 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, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   RWORK( * )
+      COMPLEX            AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBSVX uses the LU factorization to compute the solution to a complex
+*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+*  where A is a band matrix of order N with KL subdiagonals and KU
+*  superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed by this subroutine:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
+*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+*     or diag(C)*B (if TRANS = 'T' or 'C').
+*
+*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+*     matrix A (after equilibration if FACT = 'E') as
+*        A = L * U,
+*     where L is a product of permutation and unit lower triangular
+*     matrices with KL subdiagonals, and U is upper triangular with
+*     KL+KU superdiagonals.
+*
+*  3. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+*     that it solves the original system before equilibration.
+*
+*  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, AFB and IPIV contain the factored form of
+*                  A.  If EQUED is not 'N', the matrix A has been
+*                  equilibrated with scaling factors given by R and C.
+*                  AB, AFB, and IPIV are not modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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 number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
+*
+*          If FACT = 'F' and EQUED is not 'N', then A must have been
+*          equilibrated by the scaling factors in R and/or C.  AB is not
+*          modified if FACT = 'F' or 'N', or if FACT = 'E' and
+*          EQUED = 'N' on exit.
+*
+*          On exit, if EQUED .ne. 'N', A is scaled as follows:
+*          EQUED = 'R':  A := diag(R) * A
+*          EQUED = 'C':  A := A * diag(C)
+*          EQUED = 'B':  A := diag(R) * A * diag(C).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input or output) COMPLEX array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains details of the LU factorization of the band matrix
+*          A, as computed by CGBTRF.  U is stored as an upper triangular
+*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
+*          and the multipliers used during the factorization are stored
+*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is
+*          the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns details of the LU factorization of A.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns details of the LU factorization of the equilibrated
+*          matrix A (see the description of AB for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.
+*
+*  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 = L*U
+*          as computed by CGBTRF; row i of the matrix was interchanged
+*          with row IPIV(i).
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the original matrix A.
+*
+*          If FACT = 'E', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the equilibrated matrix A.
+*
+*  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) REAL 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) REAL 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) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit,
+*          if EQUED = 'N', B is not modified;
+*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+*          diag(R)*B;
+*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+*          overwritten by diag(C)*B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX 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) REAL
+*          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) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace/output) REAL array, dimension (N)
+*          On exit, RWORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If RWORK(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
+*          RWORK(1) contains the reciprocal pivot growth factor for the
+*          leading INFO columns of A.
+*
+*  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.
+*
+*  =====================================================================
+*  Moved setting of INFO = N+1 so INFO does not subsequently get
+*  overwritten.  Sven, 17 Mar 05. 
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+      CHARACTER          NORM
+      INTEGER            I, INFEQU, J, J1, J2
+      REAL               AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANGB, CLANTB, SLAMCH
+      EXTERNAL           LSAME, CLANGB, CLANTB, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGBCON, CGBEQU, CGBRFS, CGBTRF, CGBTRS,
+     $                   CLACPY, CLAQGB, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         ROWEQU = .FALSE.
+         COLEQU = .FALSE.
+      ELSE
+         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -8
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -10
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -12
+      ELSE
+         IF( ROWEQU ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 10 J = 1, N
+               RCMIN = MIN( RCMIN, R( J ) )
+               RCMAX = MAX( RCMAX, R( J ) )
+   10       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -13
+            ELSE IF( N.GT.0 ) THEN
+               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               ROWCND = ONE
+            END IF
+         END IF
+         IF( COLEQU .AND. INFO.EQ.0 ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 20 J = 1, N
+               RCMIN = MIN( RCMIN, C( J ) )
+               RCMAX = MAX( RCMAX, C( J ) )
+   20       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -14
+            ELSE IF( N.GT.0 ) THEN
+               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               COLCND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -16
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -18
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL CGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL CLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                   AMAX, EQUED )
+            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( NOTRAN ) THEN
+         IF( ROWEQU ) THEN
+            DO 40 J = 1, NRHS
+               DO 30 I = 1, N
+                  B( I, J ) = R( I )*B( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( COLEQU ) THEN
+         DO 60 J = 1, NRHS
+            DO 50 I = 1, N
+               B( I, J ) = C( I )*B( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the LU factorization of the band matrix A.
+*
+         DO 70 J = 1, N
+            J1 = MAX( J-KU, 1 )
+            J2 = MIN( J+KL, N )
+            CALL CCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
+     $                  AFB( KL+KU+1-J+J1, J ), 1 )
+   70    CONTINUE
+*
+         CALL CGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 ) THEN
+*
+*           Compute the reciprocal pivot growth factor of the
+*           leading rank-deficient INFO columns of A.
+*
+            ANORM = ZERO
+            DO 90 J = 1, INFO
+               DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+                  ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
+   80          CONTINUE
+   90       CONTINUE
+            RPVGRW = CLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
+     $                       AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
+     $                       RWORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = ANORM / RPVGRW
+            END IF
+            RWORK( 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 = CLANGB( NORM, N, KL, KU, AB, LDAB, RWORK )
+      RPVGRW = CLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, RWORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = CLANGB( 'M', N, KL, KU, AB, LDAB, RWORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
+     $             WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( NOTRAN ) THEN
+         IF( COLEQU ) THEN
+            DO 110 J = 1, NRHS
+               DO 100 I = 1, N
+                  X( I, J ) = C( I )*X( I, J )
+  100          CONTINUE
+  110       CONTINUE
+            DO 120 J = 1, NRHS
+               FERR( J ) = FERR( J ) / COLCND
+  120       CONTINUE
+         END IF
+      ELSE IF( ROWEQU ) THEN
+         DO 140 J = 1, NRHS
+            DO 130 I = 1, N
+               X( I, J ) = R( I )*X( I, J )
+  130       CONTINUE
+  140    CONTINUE
+         DO 150 J = 1, NRHS
+            FERR( J ) = FERR( J ) / ROWCND
+  150    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RWORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of CGBSVX
+*
+      END
diff --git a/SRC/cgbtf2.f b/SRC/cgbtf2.f
new file mode 100644
index 00000000..cb40ef74
--- /dev/null
+++ b/SRC/cgbtf2.f
@@ -0,0 +1,202 @@
+      SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBTF2 computes an LU factorization of a complex m-by-n band matrix
+*  A using partial pivoting with row interchanges.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U, because of fill-in resulting from the row
+*  interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JP, JU, KM, KV
+*     ..
+*     .. External Functions ..
+      INTEGER            ICAMAX
+      EXTERNAL           ICAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGERU, CSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in.
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Gaussian elimination with partial pivoting
+*
+*     Set fill-in elements in columns KU+2 to KV to zero.
+*
+      DO 20 J = KU + 2, MIN( KV, N )
+         DO 10 I = KV - J + 2, KL
+            AB( I, J ) = ZERO
+   10    CONTINUE
+   20 CONTINUE
+*
+*     JU is the index of the last column affected by the current stage
+*     of the factorization.
+*
+      JU = 1
+*
+      DO 40 J = 1, MIN( M, N )
+*
+*        Set fill-in elements in column J+KV to zero.
+*
+         IF( J+KV.LE.N ) THEN
+            DO 30 I = 1, KL
+               AB( I, J+KV ) = ZERO
+   30       CONTINUE
+         END IF
+*
+*        Find pivot and test for singularity. KM is the number of
+*        subdiagonal elements in the current column.
+*
+         KM = MIN( KL, M-J )
+         JP = ICAMAX( KM+1, AB( KV+1, J ), 1 )
+         IPIV( J ) = JP + J - 1
+         IF( AB( KV+JP, J ).NE.ZERO ) THEN
+            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
+*
+*           Apply interchange to columns J to JU.
+*
+            IF( JP.NE.1 )
+     $         CALL CSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
+     $                     AB( KV+1, J ), LDAB-1 )
+            IF( KM.GT.0 ) THEN
+*
+*              Compute multipliers.
+*
+               CALL CSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
+*
+*              Update trailing submatrix within the band.
+*
+               IF( JU.GT.J )
+     $            CALL CGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1,
+     $                        AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
+     $                        LDAB-1 )
+            END IF
+         ELSE
+*
+*           If pivot is zero, set INFO to the index of the pivot
+*           unless a zero pivot has already been found.
+*
+            IF( INFO.EQ.0 )
+     $         INFO = J
+         END IF
+   40 CONTINUE
+      RETURN
+*
+*     End of CGBTF2
+*
+      END
diff --git a/SRC/cgbtrf.f b/SRC/cgbtrf.f
new file mode 100644
index 00000000..88758b97
--- /dev/null
+++ b/SRC/cgbtrf.f
@@ -0,0 +1,442 @@
+      SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBTRF computes an LU factorization of a complex m-by-n band matrix A
+*  using partial pivoting with row interchanges.
+*
+*  This is the blocked version of the algorithm, calling 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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
+     $                   JU, K2, KM, KV, NB, NW
+      COMPLEX            TEMP
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            WORK13( LDWORK, NBMAX ),
+     $                   WORK31( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      INTEGER            ICAMAX, ILAENV
+      EXTERNAL           ICAMAX, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGBTF2, CGEMM, CGERU, CLASWP, CSCAL,
+     $                   CSWAP, CTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBTRF', -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, 'CGBTRF', ' ', M, N, KL, KU )
+*
+*     The block size must not exceed the limit set by the size of the
+*     local arrays WORK13 and WORK31.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
+*
+*        Use unblocked code
+*
+         CALL CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+*        Zero the superdiagonal elements of the work array WORK13
+*
+         DO 20 J = 1, NB
+            DO 10 I = 1, J - 1
+               WORK13( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+*
+*        Zero the subdiagonal elements of the work array WORK31
+*
+         DO 40 J = 1, NB
+            DO 30 I = J + 1, NB
+               WORK31( I, J ) = ZERO
+   30       CONTINUE
+   40    CONTINUE
+*
+*        Gaussian elimination with partial pivoting
+*
+*        Set fill-in elements in columns KU+2 to KV to zero
+*
+         DO 60 J = KU + 2, MIN( KV, N )
+            DO 50 I = KV - J + 2, KL
+               AB( I, J ) = ZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+*        JU is the index of the last column affected by the current
+*        stage of the factorization
+*
+         JU = 1
+*
+         DO 180 J = 1, MIN( M, N ), NB
+            JB = MIN( NB, MIN( M, N )-J+1 )
+*
+*           The active part of the matrix is partitioned
+*
+*              A11   A12   A13
+*              A21   A22   A23
+*              A31   A32   A33
+*
+*           Here A11, A21 and A31 denote the current block of JB columns
+*           which is about to be factorized. The number of rows in the
+*           partitioning are JB, I2, I3 respectively, and the numbers
+*           of columns are JB, J2, J3. The superdiagonal elements of A13
+*           and the subdiagonal elements of A31 lie outside the band.
+*
+            I2 = MIN( KL-JB, M-J-JB+1 )
+            I3 = MIN( JB, M-J-KL+1 )
+*
+*           J2 and J3 are computed after JU has been updated.
+*
+*           Factorize the current block of JB columns
+*
+            DO 80 JJ = J, J + JB - 1
+*
+*              Set fill-in elements in column JJ+KV to zero
+*
+               IF( JJ+KV.LE.N ) THEN
+                  DO 70 I = 1, KL
+                     AB( I, JJ+KV ) = ZERO
+   70             CONTINUE
+               END IF
+*
+*              Find pivot and test for singularity. KM is the number of
+*              subdiagonal elements in the current column.
+*
+               KM = MIN( KL, M-JJ )
+               JP = ICAMAX( KM+1, AB( KV+1, JJ ), 1 )
+               IPIV( JJ ) = JP + JJ - J
+               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
+                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
+                  IF( JP.NE.1 ) THEN
+*
+*                    Apply interchange to columns J to J+JB-1
+*
+                     IF( JP+JJ-1.LT.J+KL ) THEN
+*
+                        CALL CSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              AB( KV+JP+JJ-J, J ), LDAB-1 )
+                     ELSE
+*
+*                       The interchange affects columns J to JJ-1 of A31
+*                       which are stored in the work array WORK31
+*
+                        CALL CSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                        CALL CSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
+     $                              AB( KV+JP, JJ ), LDAB-1 )
+                     END IF
+                  END IF
+*
+*                 Compute multipliers
+*
+                  CALL CSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
+     $                        1 )
+*
+*                 Update trailing submatrix within the band and within
+*                 the current block. JM is the index of the last column
+*                 which needs to be updated.
+*
+                  JM = MIN( JU, J+JB-1 )
+                  IF( JM.GT.JJ )
+     $               CALL CGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
+     $                           AB( KV, JJ+1 ), LDAB-1,
+     $                           AB( KV+1, JJ+1 ), LDAB-1 )
+               ELSE
+*
+*                 If pivot is zero, set INFO to the index of the pivot
+*                 unless a zero pivot has already been found.
+*
+                  IF( INFO.EQ.0 )
+     $               INFO = JJ
+               END IF
+*
+*              Copy current column of A31 into the work array WORK31
+*
+               NW = MIN( JJ-J+1, I3 )
+               IF( NW.GT.0 )
+     $            CALL CCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
+     $                        WORK31( 1, JJ-J+1 ), 1 )
+   80       CONTINUE
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply the row interchanges to the other blocks.
+*
+               J2 = MIN( JU-J+1, KV ) - JB
+               J3 = MAX( 0, JU-J-KV+1 )
+*
+*              Use CLASWP to apply the row interchanges to A12, A22, and
+*              A32.
+*
+               CALL CLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
+     $                      IPIV( J ), 1 )
+*
+*              Adjust the pivot indices.
+*
+               DO 90 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+   90          CONTINUE
+*
+*              Apply the row interchanges to A13, A23, and A33
+*              columnwise.
+*
+               K2 = J - 1 + JB + J2
+               DO 110 I = 1, J3
+                  JJ = K2 + I
+                  DO 100 II = J + I - 1, J + JB - 1
+                     IP = IPIV( II )
+                     IF( IP.NE.II ) THEN
+                        TEMP = AB( KV+1+II-JJ, JJ )
+                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
+                        AB( KV+1+IP-JJ, JJ ) = TEMP
+                     END IF
+  100             CONTINUE
+  110          CONTINUE
+*
+*              Update the relevant part of the trailing submatrix
+*
+               IF( J2.GT.0 ) THEN
+*
+*                 Update A12
+*
+                  CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,
+     $                        AB( KV+1-JB, J+JB ), LDAB-1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A22
+*
+                     CALL CGEMM( 'No transpose', 'No transpose', I2, J2,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+1, J+JB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A32
+*
+                     CALL CGEMM( 'No transpose', 'No transpose', I3, J2,
+     $                           JB, -ONE, WORK31, LDWORK,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
+                  END IF
+               END IF
+*
+               IF( J3.GT.0 ) THEN
+*
+*                 Copy the lower triangle of A13 into the work array
+*                 WORK13
+*
+                  DO 130 JJ = 1, J3
+                     DO 120 II = JJ, JB
+                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
+  120                CONTINUE
+  130             CONTINUE
+*
+*                 Update A13 in the work array
+*
+                  CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,
+     $                        WORK13, LDWORK )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A23
+*
+                     CALL CGEMM( 'No transpose', 'No transpose', I2, J3,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
+     $                           LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A33
+*
+                     CALL CGEMM( 'No transpose', 'No transpose', I3, J3,
+     $                           JB, -ONE, WORK31, LDWORK, WORK13,
+     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
+                  END IF
+*
+*                 Copy the lower triangle of A13 back into place
+*
+                  DO 150 JJ = 1, J3
+                     DO 140 II = JJ, JB
+                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
+  140                CONTINUE
+  150             CONTINUE
+               END IF
+            ELSE
+*
+*              Adjust the pivot indices.
+*
+               DO 160 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+  160          CONTINUE
+            END IF
+*
+*           Partially undo the interchanges in the current block to
+*           restore the upper triangular form of A31 and copy the upper
+*           triangle of A31 back into place
+*
+            DO 170 JJ = J + JB - 1, J, -1
+               JP = IPIV( JJ ) - JJ + 1
+               IF( JP.NE.1 ) THEN
+*
+*                 Apply interchange to columns J to JJ-1
+*
+                  IF( JP+JJ-1.LT.J+KL ) THEN
+*
+*                    The interchange does not affect A31
+*
+                     CALL CSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )
+                  ELSE
+*
+*                    The interchange does affect A31
+*
+                     CALL CSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                  END IF
+               END IF
+*
+*              Copy the current column of A31 back into place
+*
+               NW = MIN( I3, JJ-J+1 )
+               IF( NW.GT.0 )
+     $            CALL CCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
+     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )
+  170       CONTINUE
+  180    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CGBTRF
+*
+      END
diff --git a/SRC/cgbtrs.f b/SRC/cgbtrs.f
new file mode 100644
index 00000000..15d6b80e
--- /dev/null
+++ b/SRC/cgbtrs.f
@@ -0,0 +1,214 @@
+      SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGBTRS solves a system of linear equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B
+*  with a general band matrix A using the LU factorization computed
+*  by CGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by CGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= N, row i of the matrix was
+*          interchanged with row IPIV(i).
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LNOTI, NOTRAN
+      INTEGER            I, J, KD, L, LM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CGERU, CLACGV, CSWAP, CTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      KD = KU + KL + 1
+      LNOTI = KL.GT.0
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve  A*X = B.
+*
+*        Solve L*X = B, overwriting B with X.
+*
+*        L is represented as a product of permutations and unit lower
+*        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
+*        where each transformation L(i) is a rank-one modification of
+*        the identity matrix.
+*
+         IF( LNOTI ) THEN
+            DO 10 J = 1, N - 1
+               LM = MIN( KL, N-J )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+               CALL CGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
+     $                     LDB, B( J+1, 1 ), LDB )
+   10       CONTINUE
+         END IF
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
+     $                  AB, LDAB, B( 1, I ), 1 )
+   20    CONTINUE
+*
+      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*        Solve A**T * X = B.
+*
+         DO 30 I = 1, NRHS
+*
+*           Solve U**T * X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
+     $                  LDAB, B( 1, I ), 1 )
+   30    CONTINUE
+*
+*        Solve L**T * X = B, overwriting B with X.
+*
+         IF( LNOTI ) THEN
+            DO 40 J = N - 1, 1, -1
+               LM = MIN( KL, N-J )
+               CALL CGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
+     $                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+   40       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Solve A**H * X = B.
+*
+         DO 50 I = 1, NRHS
+*
+*           Solve U**H * X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
+     $                  KL+KU, AB, LDAB, B( 1, I ), 1 )
+   50    CONTINUE
+*
+*        Solve L**H * X = B, overwriting B with X.
+*
+         IF( LNOTI ) THEN
+            DO 60 J = N - 1, 1, -1
+               LM = MIN( KL, N-J )
+               CALL CLACGV( NRHS, B( J, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', LM, NRHS, -ONE,
+     $                     B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE,
+     $                     B( J, 1 ), LDB )
+               CALL CLACGV( NRHS, B( J, 1 ), LDB )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+   60       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of CGBTRS
+*
+      END
diff --git a/SRC/cgebak.f b/SRC/cgebak.f
new file mode 100644
index 00000000..45e88aa8
--- /dev/null
+++ b/SRC/cgebak.f
@@ -0,0 +1,189 @@
+      SUBROUTINE CGEBAK( 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 ..
+      REAL               SCALE( * )
+      COMPLEX            V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEBAK forms the right or left eigenvectors of a complex general
+*  matrix by backward transformation on the computed eigenvectors of the
+*  balanced matrix output by CGEBAL.
+*
+*  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 CGEBAL.
+*
+*  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 CGEBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  SCALE   (input) REAL array, dimension (N)
+*          Details of the permutation and scaling factors, as returned
+*          by CGEBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) COMPLEX array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by CHSEIN or CTREVC.
+*          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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFTV, RIGHTV
+      INTEGER            I, II, K
+      REAL               S
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSSCAL, CSWAP, 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( 'CGEBAK', -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 CSSCAL( M, S, V( I, 1 ), LDV )
+   10       CONTINUE
+         END IF
+*
+         IF( LEFTV ) THEN
+            DO 20 I = ILO, IHI
+               S = ONE / SCALE( I )
+               CALL CSSCAL( 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 CSWAP( 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 CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   50       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CGEBAK
+*
+      END
diff --git a/SRC/cgebal.f b/SRC/cgebal.f
new file mode 100644
index 00000000..12394eac
--- /dev/null
+++ b/SRC/cgebal.f
@@ -0,0 +1,330 @@
+      SUBROUTINE CGEBAL( 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 ..
+      REAL               SCALE( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEBAL 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 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) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied to
+*          A.  If P(j) is the index of the row and column interchanged
+*          with row and column j and D(j) is the scaling factor
+*          applied to row and column j, then
+*          SCALE(j) = P(j)    for j = 1,...,ILO-1
+*                   = D(j)    for j = ILO,...,IHI
+*                   = P(j)    for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  INFO    (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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               SCLFAC
+      PARAMETER          ( SCLFAC = 2.0E+0 )
+      REAL               FACTOR
+      PARAMETER          ( FACTOR = 0.95E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOCONV
+      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
+      REAL               C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+     $                   SFMIN2
+      COMPLEX            CDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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( 'CGEBAL', -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 CSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL CSWAP( 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( REAL( A( J, I ) ).NE.ZERO .OR. AIMAG( 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( REAL( A( I, J ) ).NE.ZERO .OR. AIMAG( 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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      SFMAX1 = ONE / SFMIN1
+      SFMIN2 = SFMIN1*SCLFAC
+      SFMAX2 = ONE / SFMIN2
+  140 CONTINUE
+      NOCONV = .FALSE.
+*
+      DO 200 I = K, L
+         C = ZERO
+         R = ZERO
+*
+         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 = ICAMAX( L, A( 1, I ), 1 )
+         CA = ABS( A( ICA, I ) )
+         IRA = ICAMAX( 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 CSSCAL( N-K+1, G, A( I, K ), LDA )
+         CALL CSSCAL( L, F, A( 1, I ), 1 )
+*
+  200 CONTINUE
+*
+      IF( NOCONV )
+     $   GO TO 140
+*
+  210 CONTINUE
+      ILO = K
+      IHI = L
+*
+      RETURN
+*
+*     End of CGEBAL
+*
+      END
diff --git a/SRC/cgebd2.f b/SRC/cgebd2.f
new file mode 100644
index 00000000..8317128d
--- /dev/null
+++ b/SRC/cgebd2.f
@@ -0,0 +1,250 @@
+      SUBROUTINE CGEBD2( 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 ..
+      REAL               D( * ), E( * )
+      COMPLEX            A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEBD2 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 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) REAL array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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 array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q. See Further Details.
+*
+*  TAUP    (output) COMPLEX array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix P. See Further Details.
+*
+*  WORK    (workspace) COMPLEX 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, CLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CGEBD2', -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 CLARFG( 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 CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                     CONJG( 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 CLACGV( N-I, A( I, I+1 ), LDA )
+               ALPHA = A( I, I+1 )
+               CALL CLARFG( 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 CLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+               CALL CLACGV( 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 CLACGV( N-I+1, A( I, I ), LDA )
+            ALPHA = A( I, I )
+            CALL CLARFG( 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 CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
+            CALL CLACGV( 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 CLARFG( 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 CLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
+     $                     CONJG( 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 CGEBD2
+*
+      END
diff --git a/SRC/cgebrd.f b/SRC/cgebrd.f
new file mode 100644
index 00000000..4ee39f66
--- /dev/null
+++ b/SRC/cgebrd.f
@@ -0,0 +1,269 @@
+      SUBROUTINE CGEBRD( 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 ..
+      REAL               D( * ), E( * )
+      COMPLEX            A( LDA, * ), TAUP( * ), TAUQ( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEBRD 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 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) REAL array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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 array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q. See Further Details.
+*
+*  TAUP    (output) COMPLEX 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
+     $                   NBMIN, NX
+      REAL               WS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEBD2, CGEMM, CLABRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB = MAX( 1, ILAENV( 1, 'CGEBRD', ' ', M, N, -1, -1 ) )
+      LWKOPT = ( M+N )*NB
+      WORK( 1 ) = REAL( 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( 'CGEBRD', -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, 'CGEBRD', ' ', 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, 'CGEBRD', ' ', 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 CLABRD( 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 CGEMM( '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 CGEMM( '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 CGEBD2( 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 CGEBRD
+*
+      END
diff --git a/SRC/cgecon.f b/SRC/cgecon.f
new file mode 100644
index 00000000..a4673e26
--- /dev/null
+++ b/SRC/cgecon.f
@@ -0,0 +1,193 @@
+      SUBROUTINE CGECON( 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 CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGECON 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 CGETRF.
+*
+*  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 array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by CGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) REAL
+*          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) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, SCALE, SL, SMLNUM, SU
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATRS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( 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( 'CGECON', -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 = SLAMCH( '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 CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            CALL CLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
+     $                   LDA, WORK, SL, RWORK, INFO )
+*
+*           Multiply by inv(U).
+*
+            CALL CLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SU, RWORK( N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL CLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, A, LDA, WORK, SU, RWORK( N+1 ),
+     $                   INFO )
+*
+*           Multiply by inv(L').
+*
+            CALL CLATRS( '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 = ICAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL CSRSCL( 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 CGECON
+*
+      END
diff --git a/SRC/cgeequ.f b/SRC/cgeequ.f
new file mode 100644
index 00000000..93a1283c
--- /dev/null
+++ b/SRC/cgeequ.f
@@ -0,0 +1,233 @@
+      SUBROUTINE CGEEQU( 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
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), R( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEEQU 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) COMPLEX 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) REAL array, dimension (M)
+*          If INFO = 0 or INFO > M, R contains the row scale factors
+*          for A.
+*
+*  C       (output) REAL array, dimension (N)
+*          If INFO = 0,  C contains the column scale factors for A.
+*
+*  ROWCND  (output) REAL
+*          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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               BIGNUM, RCMAX, RCMIN, SMLNUM
+      COMPLEX            ZDUM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CGEEQU', -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 = SLAMCH( '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 ), CABS1( 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 ), CABS1( 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 CGEEQU
+*
+      END
diff --git a/SRC/cgees.f b/SRC/cgees.f
new file mode 100644
index 00000000..648de4ff
--- /dev/null
+++ b/SRC/cgees.f
@@ -0,0 +1,324 @@
+      SUBROUTINE CGEES( 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( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEES 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 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 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 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 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 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTST, WANTVS
+      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
+     $                   ITAU, IWRK, MAXWRK, MINWRK
+      REAL               ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY,
+     $                   CLASCL, CTRSEN, CUNGHR, SLABAD, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. 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 CHSEQR, 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, 'CGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 2*N
+*
+            CALL CHSEQR( '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, 'CUNGHR',
+     $                       ' ', 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( 'CGEES ', -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 = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( '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 CGEBAL( '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 CGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL CLACPY( '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 CUNGHR( 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 CHSEQR( '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 CLASCL( '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 CTRSEN( '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 CGEBAK( '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 CLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL CCOPY( N, A, LDA+1, W, 1 )
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of CGEES
+*
+      END
diff --git a/SRC/cgeesx.f b/SRC/cgeesx.f
new file mode 100644
index 00000000..c0f1f7d0
--- /dev/null
+++ b/SRC/cgeesx.f
@@ -0,0 +1,384 @@
+      SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W,
+     $                   VS, LDVS, RCONDE, RCONDV, 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, SENSE, SORT
+      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
+      REAL               RCONDE, RCONDV
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEESX 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;
+*  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 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 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.
+*          An eigenvalue W(j) is selected if SELECT(W(j)) is true.
+*
+*  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) COMPLEX array, dimension (LDA, N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A is 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 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 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, and if
+*          JOBVS = 'V', LDVS >= N.
+*
+*  RCONDE  (output) REAL
+*          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) REAL
+*          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) COMPLEX 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).
+*          Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
+*          where SDIM is the number of selected eigenvalues computed by
+*          this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also
+*          that an error is only returned if LWORK < max(1,2*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 bound on the optimal size of the
+*          array WORK, returns this value as the first entry of the WORK
+*          array, and no error message related to LWORK is issued by
+*          XERBLA.
+*
+*  RWORK   (workspace) REAL 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 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SCALEA, WANTSB, WANTSE, WANTSN, WANTST,
+     $                   WANTSV, WANTVS
+      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
+     $                   ITAU, IWRK, LWRK, MAXWRK, MINWRK
+      REAL               ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY,
+     $                   CLASCL, CTRSEN, CUNGHR, SLABAD, SLASCL, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. 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' )
+      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 = -11
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of real 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 CHSEQR, 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 CTRSEN later
+*       in the code.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            LWRK = 1
+         ELSE
+            MAXWRK = N + N*ILAENV( 1, 'CGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 2*N
+*
+            CALL CHSEQR( '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, 'CUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+            END IF
+            LWRK = MAXWRK
+            IF( .NOT.WANTSN )
+     $         LWRK = MAX( LWRK, ( N*N )/2 )
+         END IF
+         WORK( 1 ) = LWRK
+*
+         IF( LWORK.LT.MINWRK ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGEESX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( '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 CGEBAL( '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 CGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL CLACPY( '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 CUNGHR( 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 CHSEQR( '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 CLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
+         DO 10 I = 1, N
+            BWORK( I ) = SELECT( W( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues, transform Schur vectors, and compute
+*        reciprocal condition numbers
+*        (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM)
+*                     otherwise, need none )
+*        (RWorkspace: none)
+*
+         CALL CTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
+     $                RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
+     $                ICOND )
+         IF( .NOT.WANTSN )
+     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+         IF( ICOND.EQ.-14 ) THEN
+*
+*           Not enough complex workspace
+*
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( WANTVS ) THEN
+*
+*        Undo balancing
+*        (CWorkspace: none)
+*        (RWorkspace: need N)
+*
+         CALL CGEBAK( '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 CLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL CCOPY( N, A, LDA+1, W, 1 )
+         IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
+            DUM( 1 ) = RCONDV
+            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+            RCONDV = DUM( 1 )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of CGEESX
+*
+      END
diff --git a/SRC/cgeev.f b/SRC/cgeev.f
new file mode 100644
index 00000000..8a493c83
--- /dev/null
+++ b/SRC/cgeev.f
@@ -0,0 +1,397 @@
+      SUBROUTINE CGEEV( 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 ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEEV 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 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 array, dimension (N)
+*          W contains the computed eigenvalues.
+*
+*  VL      (output) COMPLEX 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 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 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
+      CHARACTER          SIDE
+      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
+     $                   IWRK, K, MAXWRK, MINWRK, NOUT
+      REAL               ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
+      COMPLEX            TMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            SELECT( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY, CLASCL,
+     $                   CSCAL, CSSCAL, CTREVC, CUNGHR, SLABAD, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV, ISAMAX
+      REAL               CLANGE, SCNRM2, SLAMCH
+      EXTERNAL           LSAME, ILAENV, ISAMAX, CLANGE, SCNRM2, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, CONJG, MAX, REAL, 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 CHSEQR, 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, 'CGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 2*N
+            IF( WANTVL ) THEN
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'CUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               CALL CHSEQR( '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, 'CUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+            ELSE
+               CALL CHSEQR( '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( 'CGEEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix
+*     (CWorkspace: none)
+*     (RWorkspace: need N)
+*
+      IBAL = 1
+      CALL CGEBAL( '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 CGEHRD( 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 CLACPY( '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 CUNGHR( 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 CHSEQR( '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 CLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL CLACPY( '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 CUNGHR( 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 CHSEQR( '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 CHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 0 from CHSEQR, 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 CTREVC( 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 CGEBAK( '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 / SCNRM2( N, VL( 1, I ), 1 )
+            CALL CSSCAL( N, SCL, VL( 1, I ), 1 )
+            DO 10 K = 1, N
+               RWORK( IRWORK+K-1 ) = REAL( VL( K, I ) )**2 +
+     $                               AIMAG( VL( K, I ) )**2
+   10       CONTINUE
+            K = ISAMAX( N, RWORK( IRWORK ), 1 )
+            TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
+            CALL CSCAL( N, TMP, VL( 1, I ), 1 )
+            VL( K, I ) = CMPLX( REAL( VL( K, I ) ), ZERO )
+   20    CONTINUE
+      END IF
+*
+      IF( WANTVR ) THEN
+*
+*        Undo balancing of right eigenvectors
+*        (CWorkspace: none)
+*        (RWorkspace: need N)
+*
+         CALL CGEBAK( '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 / SCNRM2( N, VR( 1, I ), 1 )
+            CALL CSSCAL( N, SCL, VR( 1, I ), 1 )
+            DO 30 K = 1, N
+               RWORK( IRWORK+K-1 ) = REAL( VR( K, I ) )**2 +
+     $                               AIMAG( VR( K, I ) )**2
+   30       CONTINUE
+            K = ISAMAX( N, RWORK( IRWORK ), 1 )
+            TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
+            CALL CSCAL( N, TMP, VR( 1, I ), 1 )
+            VR( K, I ) = CMPLX( REAL( VR( K, I ) ), ZERO )
+   40    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+   50 CONTINUE
+      IF( SCALEA ) THEN
+         CALL CLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.GT.0 ) THEN
+            CALL CLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of CGEEV
+*
+      END
diff --git a/SRC/cgeevx.f b/SRC/cgeevx.f
new file mode 100644
index 00000000..7bcbd323
--- /dev/null
+++ b/SRC/cgeevx.f
@@ -0,0 +1,532 @@
+      SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL,
+     $                   LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE,
+     $                   RCONDV, 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          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
+      REAL               ABNRM
+*     ..
+*     .. Array Arguments ..
+      REAL               RCONDE( * ), RCONDV( * ), RWORK( * ),
+     $                   SCALE( * )
+      COMPLEX            A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
+*  eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+*  Optionally also, it computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
+*  (RCONDE), and reciprocal condition numbers for the right
+*  eigenvectors (RCONDV).
+*
+*  The right eigenvector v(j) of A satisfies
+*                   A * v(j) = lambda(j) * v(j)
+*  where lambda(j) is its eigenvalue.
+*  The left eigenvector u(j) of A satisfies
+*                u(j)**H * A = lambda(j) * u(j)**H
+*  where u(j)**H denotes the conjugate transpose of u(j).
+*
+*  The computed eigenvectors are normalized to have Euclidean norm
+*  equal to 1 and largest component real.
+*
+*  Balancing a matrix means permuting the rows and columns to make it
+*  more nearly upper triangular, and applying a diagonal similarity
+*  transformation D * A * D**(-1), where D is a diagonal matrix, to
+*  make its rows and columns closer in norm and the condition numbers
+*  of its eigenvalues and eigenvectors smaller.  The computed
+*  reciprocal condition numbers correspond to the balanced matrix.
+*  Permuting rows and columns will not change the condition numbers
+*  (in exact arithmetic) but diagonal scaling will.  For further
+*  explanation of balancing, see section 4.10.2 of the LAPACK
+*  Users' Guide.
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Indicates how the input matrix should be diagonally scaled
+*          and/or permuted to improve the conditioning of its
+*          eigenvalues.
+*          = 'N': Do not diagonally scale or permute;
+*          = 'P': Perform permutations to make the matrix more nearly
+*                 upper triangular. Do not diagonally scale;
+*          = 'S': Diagonally scale the matrix, ie. replace A by
+*                 D*A*D**(-1), where D is a diagonal matrix chosen
+*                 to make the rows and columns of A more equal in
+*                 norm. Do not permute;
+*          = 'B': Both diagonally scale and permute A.
+*
+*          Computed reciprocal condition numbers will be for the matrix
+*          after balancing and/or permuting. Permuting does not change
+*          condition numbers (in exact arithmetic), but balancing does.
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N': left eigenvectors of A are not computed;
+*          = 'V': left eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVL must = 'V'.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N': right eigenvectors of A are not computed;
+*          = 'V': right eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVR must = 'V'.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': None are computed;
+*          = 'E': Computed for eigenvalues only;
+*          = 'V': Computed for right eigenvectors only;
+*          = 'B': Computed for eigenvalues and right eigenvectors.
+*
+*          If SENSE = 'E' or 'B', both left and right eigenvectors
+*          must also be computed (JOBVL = 'V' and JOBVR = 'V').
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A has been overwritten.  If JOBVL = 'V' or
+*          JOBVR = 'V', A contains the Schur form of the balanced 
+*          version of the matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  W       (output) COMPLEX array, dimension (N)
+*          W contains the computed eigenvalues.
+*
+*  VL      (output) COMPLEX 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 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.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values determined when A was
+*          balanced.  The balanced A(i,j) = 0 if I > J and
+*          J = 1,...,ILO-1 or I = IHI+1,...,N.
+*
+*  SCALE   (output) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          when balancing A.  If P(j) is the index of the row and column
+*          interchanged with row and column j, and D(j) is the scaling
+*          factor applied to row and column j, then
+*          SCALE(J) = P(J),    for J = 1,...,ILO-1
+*                   = D(J),    for J = ILO,...,IHI
+*                   = P(J)     for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) REAL
+*          The one-norm of the balanced matrix (the maximum
+*          of the sum of absolute values of elements of any column).
+*
+*  RCONDE  (output) REAL array, dimension (N)
+*          RCONDE(j) is the reciprocal condition number of the j-th
+*          eigenvalue.
+*
+*  RCONDV  (output) REAL array, dimension (N)
+*          RCONDV(j) is the reciprocal condition number of the j-th
+*          right eigenvector.
+*
+*  WORK    (workspace/output) COMPLEX 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 SENSE = 'N' or 'E',
+*          LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
+*          LWORK >= N*N+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) REAL 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 or condition numbers
+*                have been computed; elements 1:ILO-1 and i+1:N of W
+*                contain eigenvalues which have converged.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
+     $                   WNTSNN, WNTSNV
+      CHARACTER          JOB, SIDE
+      INTEGER            HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
+     $                   MINWRK, NOUT
+      REAL               ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
+      COMPLEX            TMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            SELECT( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEBAK, CGEBAL, CGEHRD, CHSEQR, CLACPY, CLASCL,
+     $                   CSCAL, CSSCAL, CTREVC, CTRSNA, CUNGHR, SLABAD,
+     $                   SLASCL, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV, ISAMAX
+      REAL               CLANGE, SCNRM2, SLAMCH
+      EXTERNAL           LSAME, ILAENV, ISAMAX, CLANGE, SCNRM2, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, CONJG, MAX, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVL = LSAME( JOBVL, 'V' )
+      WANTVR = LSAME( JOBVR, 'V' )
+      WNTSNN = LSAME( SENSE, 'N' )
+      WNTSNE = LSAME( SENSE, 'E' )
+      WNTSNV = LSAME( SENSE, 'V' )
+      WNTSNB = LSAME( SENSE, 'B' )
+      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) .OR.
+     $    LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
+     $         ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
+     $         WANTVR ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -12
+      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 CHSEQR, 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, 'CGEHRD', ' ', N, 1, N, 0 )
+*
+            IF( WANTVL ) THEN
+               CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
+     $                WORK, -1, INFO )
+            ELSE IF( WANTVR ) THEN
+               CALL CHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+            ELSE
+               IF( WNTSNN ) THEN
+                  CALL CHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+               ELSE
+                  CALL CHSEQR( 'S', 'N', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+               END IF
+            END IF
+            HSWORK = WORK( 1 )
+*
+            IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+               MINWRK = 2*N
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MINWRK = MAX( MINWRK, N*N + 2*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MAXWRK = MAX( MAXWRK, N*N + 2*N )
+            ELSE
+               MINWRK = 2*N
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MINWRK = MAX( MINWRK, N*N + 2*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'CUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MAXWRK = MAX( MAXWRK, N*N + 2*N )
+               MAXWRK = MAX( MAXWRK, 2*N )
+            END IF
+            MAXWRK = MAX( MAXWRK, MINWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGEEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ICOND = 0
+      ANRM = CLANGE( '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 CLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix and compute ABNRM
+*
+      CALL CGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
+      ABNRM = CLANGE( '1', N, N, A, LDA, DUM )
+      IF( SCALEA ) THEN
+         DUM( 1 ) = ABNRM
+         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+         ABNRM = DUM( 1 )
+      END IF
+*
+*     Reduce to upper Hessenberg form
+*     (CWorkspace: need 2*N, prefer N+N*NB)
+*     (RWorkspace: none)
+*
+      ITAU = 1
+      IWRK = ITAU + N
+      CALL CGEHRD( 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 CLACPY( '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 CUNGHR( 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 CHSEQR( '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 CLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL CLACPY( '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 CUNGHR( 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 CHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+      ELSE
+*
+*        Compute eigenvalues only
+*        If condition numbers desired, compute Schur form
+*
+         IF( WNTSNN ) THEN
+            JOB = 'E'
+         ELSE
+            JOB = 'S'
+         END IF
+*
+*        (CWorkspace: need 1, prefer HSWORK (see comments) )
+*        (RWorkspace: none)
+*
+         IWRK = ITAU
+         CALL CHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 0 from CHSEQR, 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 N)
+*
+         CALL CTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                N, NOUT, WORK( IWRK ), RWORK, IERR )
+      END IF
+*
+*     Compute condition numbers if desired
+*     (CWorkspace: need N*N+2*N unless SENSE = 'E')
+*     (RWorkspace: need 2*N unless SENSE = 'E')
+*
+      IF( .NOT.WNTSNN ) THEN
+         CALL CTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, RWORK,
+     $                ICOND )
+      END IF
+*
+      IF( WANTVL ) THEN
+*
+*        Undo balancing of left eigenvectors
+*
+         CALL CGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
+     $                IERR )
+*
+*        Normalize left eigenvectors and make largest component real
+*
+         DO 20 I = 1, N
+            SCL = ONE / SCNRM2( N, VL( 1, I ), 1 )
+            CALL CSSCAL( N, SCL, VL( 1, I ), 1 )
+            DO 10 K = 1, N
+               RWORK( K ) = REAL( VL( K, I ) )**2 +
+     $                      AIMAG( VL( K, I ) )**2
+   10       CONTINUE
+            K = ISAMAX( N, RWORK, 1 )
+            TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( K ) )
+            CALL CSCAL( N, TMP, VL( 1, I ), 1 )
+            VL( K, I ) = CMPLX( REAL( VL( K, I ) ), ZERO )
+   20    CONTINUE
+      END IF
+*
+      IF( WANTVR ) THEN
+*
+*        Undo balancing of right eigenvectors
+*
+         CALL CGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
+     $                IERR )
+*
+*        Normalize right eigenvectors and make largest component real
+*
+         DO 40 I = 1, N
+            SCL = ONE / SCNRM2( N, VR( 1, I ), 1 )
+            CALL CSSCAL( N, SCL, VR( 1, I ), 1 )
+            DO 30 K = 1, N
+               RWORK( K ) = REAL( VR( K, I ) )**2 +
+     $                      AIMAG( VR( K, I ) )**2
+   30       CONTINUE
+            K = ISAMAX( N, RWORK, 1 )
+            TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( K ) )
+            CALL CSCAL( N, TMP, VR( 1, I ), 1 )
+            VR( K, I ) = CMPLX( REAL( VR( K, I ) ), ZERO )
+   40    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+   50 CONTINUE
+      IF( SCALEA ) THEN
+         CALL CLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.EQ.0 ) THEN
+            IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
+     $         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
+     $                      IERR )
+         ELSE
+            CALL CLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of CGEEVX
+*
+      END
diff --git a/SRC/cgegs.f b/SRC/cgegs.f
new file mode 100644
index 00000000..754ee7f9
--- /dev/null
+++ b/SRC/cgegs.f
@@ -0,0 +1,427 @@
+      SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA,
+     $                  VSL, LDVSL, VSR, LDVSR, 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          JOBVSL, JOBVSR
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine CGGES.
+*
+*  CGEGS computes the eigenvalues, Schur form, and, optionally, the
+*  left and or/right Schur vectors of a complex matrix pair (A,B).
+*  Given two square matrices A and B, the generalized Schur
+*  factorization has the form
+*  
+*     A = Q*S*Z**H,  B = Q*T*Z**H
+*  
+*  where Q and Z are unitary matrices and S and T are upper triangular.
+*  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
+*  CGEGV should be used instead.  See CGEGV 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) COMPLEX array, dimension (LDA, N)
+*          On entry, the matrix A.
+*          On exit, the upper triangular matrix S from the generalized
+*          Schur factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB, N)
+*          On entry, the matrix B.
+*          On exit, the upper triangular matrix T from the generalized
+*          Schur factorization.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX array, dimension (N)
+*          The complex scalars alpha that define the eigenvalues of
+*          GNEP.  ALPHA(j) = S(j,j), the diagonal element of the Schur
+*          form of A.
+*
+*  BETA    (output) COMPLEX array, dimension (N)
+*          The non-negative real scalars beta that define the
+*          eigenvalues of GNEP.  BETA(j) = T(j,j), the diagonal element
+*          of the triangular factor T.
+*
+*          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.
+*
+*  VSL     (output) COMPLEX 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) COMPLEX 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) COMPLEX 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.
+*          To compute the optimal value of LWORK, call ILAENV to get
+*          blocksizes (for CGEQRF, CUNMQR, and CUNGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
+*          the optimal LWORK is 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.
+*
+*  RWORK   (workspace) REAL array, dimension (3*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:  errors that usually indicate LAPACK problems:
+*                =N+1: error return from CGGBAL
+*                =N+2: error return from CGEQRF
+*                =N+3: error return from CUNMQR
+*                =N+4: error return from CUNGQR
+*                =N+5: error return from CGGHRD
+*                =N+6: error return from CHGEQZ (other than failed
+*                                               iteration)
+*                =N+7: error return from CGGBAK (computing VSL)
+*                =N+8: error return from CGGBAK (computing VSR)
+*                =N+9: error return from CLASCL (various places)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT,
+     $                   ILO, IRIGHT, IROWS, IRWORK, ITAU, IWORK,
+     $                   LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SAFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
+     $                   CLASCL, CLASET, CUNGQR, CUNMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           ILAENV, LSAME, CLANGE, SLAMCH
+*     ..
+*     .. 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( 2*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 = -11
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -15
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB1 = ILAENV( 1, 'CGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'CUNMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'CUNGQR', ' ', N, N, N, -1 )
+         NB = MAX( NB1, NB2, NB3 )
+         LOPT = N*(NB+1)
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGEGS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+      SAFMIN = SLAMCH( 'S' )
+      SMLNUM = N*SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 ) THEN
+         CALL CLASCL( '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 = CLANGE( '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 ) THEN
+         CALL CLASCL( '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
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IRWORK = IRIGHT + N
+      IWORK = 1
+      CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
+     $             RWORK( IRIGHT ), RWORK( IRWORK ), 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
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = IWORK
+      IWORK = ITAU + IROWS
+      CALL CGEQRF( 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 CUNMQR( 'L', 'C', 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 CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
+         CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VSL( ILO+1, ILO ), LDVSL )
+         CALL CUNGQR( 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 CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      CALL CGGHRD( 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
+*
+      IWORK = ITAU
+      CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWORK ),
+     $             LWORK+1-IWORK, RWORK( IRWORK ), 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 CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSL, LDVSL, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 10
+         END IF
+      END IF
+      IF( ILVSR ) THEN
+         CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( 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 CLASCL( 'U', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL CLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHA, N, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL CLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL CLASCL( '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 CGEGS
+*
+      END
diff --git a/SRC/cgegv.f b/SRC/cgegv.f
new file mode 100644
index 00000000..dab2b022
--- /dev/null
+++ b/SRC/cgegv.f
@@ -0,0 +1,602 @@
+      SUBROUTINE CGEGV( 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 ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine CGGEV.
+*
+*  CGEGV computes the eigenvalues and, optionally, the left and/or right
+*  eigenvectors of a complex matrix pair (A,B).
+*  Given two square matrices A and B,
+*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
+*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such
+*  that
+*     A*x = lambda*B*x.
+*
+*  An alternate form is to find the eigenvalues mu and corresponding
+*  eigenvectors y such that
+*     mu*A*y = B*y.
+*
+*  These two forms are equivalent with mu = 1/lambda and x = y if
+*  neither lambda nor mu is zero.  In order to deal with the case that
+*  lambda or mu is zero or small, two values alpha and beta are returned
+*  for each eigenvalue, such that lambda = alpha/beta and
+*  mu = beta/alpha.
+*  
+*  The vectors x and y in the above equations are right eigenvectors of
+*  the matrix pair (A,B).  Vectors u and v satisfying
+*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B
+*  are left eigenvectors of (A,B).
+*
+*  Note: this routine performs "full balancing" on A and B -- see
+*  "Further Details", below.
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N':  do not compute the left generalized eigenvectors;
+*          = 'V':  compute the left generalized eigenvectors (returned
+*                  in VL).
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N':  do not compute the right generalized eigenvectors;
+*          = 'V':  compute the right generalized eigenvectors (returned
+*                  in VR).
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VL, and VR.  N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA, N)
+*          On entry, the matrix A.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit A
+*          contains the Schur form of A from the generalized Schur
+*          factorization of the pair (A,B) after balancing.  If no
+*          eigenvectors were computed, then only the diagonal elements
+*          of the Schur form will be correct.  See CGGHRD and CHGEQZ
+*          for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB, N)
+*          On entry, the matrix B.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
+*          upper triangular matrix obtained from B in the generalized
+*          Schur factorization of the pair (A,B) after balancing.
+*          If no eigenvectors were computed, then only the diagonal
+*          elements of B will be correct.  See CGGHRD and CHGEQZ for
+*          details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX array, dimension (N)
+*          The complex scalars alpha that define the eigenvalues of
+*          GNEP.
+*
+*  BETA    (output) COMPLEX array, dimension (N)
+*          The complex scalars beta that define the eigenvalues of GNEP.
+*          
+*          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.
+
+*
+*  VL      (output) COMPLEX array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored
+*          in the columns of VL, in the same order as their eigenvalues.
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvectors
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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 array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right eigenvectors x(j) are stored
+*          in the columns of VR, in the same order as their eigenvalues.
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvectors
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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 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.
+*          To compute the optimal value of LWORK, call ILAENV to get
+*          blocksizes (for CGEQRF, CUNMQR, and CUNGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
+*          The optimal LWORK is  MAX( 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.
+*
+*  RWORK   (workspace/output) REAL 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:  errors that usually indicate LAPACK problems:
+*                =N+1: error return from CGGBAL
+*                =N+2: error return from CGEQRF
+*                =N+3: error return from CUNMQR
+*                =N+4: error return from CUNGQR
+*                =N+5: error return from CGGHRD
+*                =N+6: error return from CHGEQZ (other than failed
+*                                               iteration)
+*                =N+7: error return from CTGEVC
+*                =N+8: error return from CGGBAK (computing VL)
+*                =N+9: error return from CGGBAK (computing VR)
+*                =N+10: error return from CLASCL (various calls)
+*
+*  Further Details
+*  ===============
+*
+*  Balancing
+*  ---------
+*
+*  This driver calls CGGBAL to both permute and scale rows and columns
+*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
+*  and PL*B*R will be upper triangular except for the diagonal blocks
+*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
+*  possible.  The diagonal scaling matrices DL and DR are chosen so
+*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
+*  one (except for the elements that start out zero.)
+*
+*  After the eigenvalues and eigenvectors of the balanced matrices
+*  have been computed, CGGBAK transforms the eigenvectors back to what
+*  they would have been (in perfect arithmetic) if they had not been
+*  balanced.
+*
+*  Contents of A and B on Exit
+*  -------- -- - --- - -- ----
+*
+*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
+*  both), then on exit the arrays A and B will contain the complex Schur
+*  form[*] of the "balanced" versions of A and B.  If no eigenvectors
+*  are computed, then only the diagonal blocks will be correct.
+*
+*  [*] In other words, upper triangular form.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILIMIT, ILV, ILVL, ILVR, LQUERY
+      CHARACTER          CHTEMP
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IN, IRIGHT, IROWS, IRWORK, ITAU, IWORK, JC, JR,
+     $                   LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+      REAL               ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
+     $                   BNRM1, BNRM2, EPS, SAFMAX, SAFMIN, SALFAI,
+     $                   SALFAR, SBETA, SCALE, TEMP
+      COMPLEX            X
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
+     $                   CLASCL, CLASET, CTGEVC, CUNGQR, CUNMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           ILAENV, LSAME, CLANGE, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, INT, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( 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
+*
+      LWKMIN = MAX( 2*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( 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
+      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -15
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB1 = ILAENV( 1, 'CGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'CUNMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'CUNGQR', ' ', N, N, N, -1 )
+         NB = MAX( NB1, NB2, NB3 )
+         LOPT = MAX( 2*N, N*(NB+1) )
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGEGV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+      SAFMIN = SLAMCH( 'S' )
+      SAFMIN = SAFMIN + SAFMIN
+      SAFMAX = ONE / SAFMIN
+*
+*     Scale A
+*
+      ANRM = CLANGE( 'M', N, N, A, LDA, RWORK )
+      ANRM1 = ANRM
+      ANRM2 = ONE
+      IF( ANRM.LT.ONE ) THEN
+         IF( SAFMAX*ANRM.LT.ONE ) THEN
+            ANRM1 = SAFMIN
+            ANRM2 = SAFMAX*ANRM
+         END IF
+      END IF
+*
+      IF( ANRM.GT.ZERO ) THEN
+         CALL CLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Scale B
+*
+      BNRM = CLANGE( 'M', N, N, B, LDB, RWORK )
+      BNRM1 = BNRM
+      BNRM2 = ONE
+      IF( BNRM.LT.ONE ) THEN
+         IF( SAFMAX*BNRM.LT.ONE ) THEN
+            BNRM1 = SAFMIN
+            BNRM2 = SAFMAX*BNRM
+         END IF
+      END IF
+*
+      IF( BNRM.GT.ZERO ) THEN
+         CALL CLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Permute the matrix to make it more nearly triangular
+*     Also "balance" the matrix.
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IRWORK = IRIGHT + N
+      CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
+     $             RWORK( IRIGHT ), RWORK( IRWORK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 1
+         GO TO 80
+      END IF
+*
+*     Reduce B to triangular form, and initialize VL and/or VR
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWORK = ITAU + IROWS
+      CALL CGEQRF( 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 80
+      END IF
+*
+      CALL CUNMQR( 'L', 'C', 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 80
+      END IF
+*
+      IF( ILVL ) THEN
+         CALL CLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
+         CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VL( ILO+1, ILO ), LDVL )
+         CALL CUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                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 80
+         END IF
+      END IF
+*
+      IF( ILVR )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      IF( ILV ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL CGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IINFO )
+      ELSE
+         CALL CGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
+      END IF
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 5
+         GO TO 80
+      END IF
+*
+*     Perform QZ algorithm
+*
+      IWORK = ITAU
+      IF( ILV ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+      CALL CHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWORK ),
+     $             LWORK+1-IWORK, RWORK( IRWORK ), 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 80
+      END IF
+*
+      IF( ILV ) THEN
+*
+*        Compute Eigenvectors
+*
+         IF( ILVL ) THEN
+            IF( ILVR ) THEN
+               CHTEMP = 'B'
+            ELSE
+               CHTEMP = 'L'
+            END IF
+         ELSE
+            CHTEMP = 'R'
+         END IF
+*
+         CALL CTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+     $                VR, LDVR, N, IN, WORK( IWORK ), RWORK( IRWORK ),
+     $                IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 80
+         END IF
+*
+*        Undo balancing on VL and VR, rescale
+*
+         IF( ILVL ) THEN
+            CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                   RWORK( IRIGHT ), N, VL, LDVL, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 8
+               GO TO 80
+            END IF
+            DO 30 JC = 1, N
+               TEMP = ZERO
+               DO 10 JR = 1, N
+                  TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
+   10          CONTINUE
+               IF( TEMP.LT.SAFMIN )
+     $            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 CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                   RWORK( IRIGHT ), N, VR, LDVR, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 9
+               GO TO 80
+            END IF
+            DO 60 JC = 1, N
+               TEMP = ZERO
+               DO 40 JR = 1, N
+                  TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
+   40          CONTINUE
+               IF( TEMP.LT.SAFMIN )
+     $            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 of eigenvector calculation
+*
+      END IF
+*
+*     Undo scaling in alpha, beta
+*
+*     Note: this does not give the alpha and beta for the unscaled
+*     problem.
+*
+*     Un-scaling is limited to avoid underflow in alpha and beta
+*     if they are significant.
+*
+      DO 70 JC = 1, N
+         ABSAR = ABS( REAL( ALPHA( JC ) ) )
+         ABSAI = ABS( AIMAG( ALPHA( JC ) ) )
+         ABSB = ABS( REAL( BETA( JC ) ) )
+         SALFAR = ANRM*REAL( ALPHA( JC ) )
+         SALFAI = ANRM*AIMAG( ALPHA( JC ) )
+         SBETA = BNRM*REAL( BETA( JC ) )
+         ILIMIT = .FALSE.
+         SCALE = ONE
+*
+*        Check for significant underflow in imaginary part of ALPHA
+*
+         IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = ( SAFMIN / ANRM1 ) / MAX( SAFMIN, ANRM2*ABSAI )
+         END IF
+*
+*        Check for significant underflow in real part of ALPHA
+*
+         IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
+     $       MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( SAFMIN / ANRM1 ) /
+     $              MAX( SAFMIN, ANRM2*ABSAR ) )
+         END IF
+*
+*        Check for significant underflow in BETA
+*
+         IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( SAFMIN / BNRM1 ) /
+     $              MAX( SAFMIN, BNRM2*ABSB ) )
+         END IF
+*
+*        Check for possible overflow when limiting scaling
+*
+         IF( ILIMIT ) THEN
+            TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
+     $             ABS( SBETA ) )
+            IF( TEMP.GT.ONE )
+     $         SCALE = SCALE / TEMP
+            IF( SCALE.LT.ONE )
+     $         ILIMIT = .FALSE.
+         END IF
+*
+*        Recompute un-scaled ALPHA, BETA if necessary.
+*
+         IF( ILIMIT ) THEN
+            SALFAR = ( SCALE*REAL( ALPHA( JC ) ) )*ANRM
+            SALFAI = ( SCALE*AIMAG( ALPHA( JC ) ) )*ANRM
+            SBETA = ( SCALE*BETA( JC ) )*BNRM
+         END IF
+         ALPHA( JC ) = CMPLX( SALFAR, SALFAI )
+         BETA( JC ) = SBETA
+   70 CONTINUE
+*
+   80 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CGEGV
+*
+      END
diff --git a/SRC/cgehd2.f b/SRC/cgehd2.f
new file mode 100644
index 00000000..c3cb2b71
--- /dev/null
+++ b/SRC/cgehd2.f
@@ -0,0 +1,148 @@
+      SUBROUTINE CGEHD2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEHD2 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 CGEBAL; otherwise they should be
+*          set to 1 and N respectively. See Further Details.
+*          1 <= ILO <= IHI <= max(1,N).
+*
+*  A       (input/output) COMPLEX 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 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CGEHD2', -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 CLARFG( 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 CLARF( '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 CLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
+     $               CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
+*
+         A( I+1, I ) = ALPHA
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of CGEHD2
+*
+      END
diff --git a/SRC/cgehrd.f b/SRC/cgehrd.f
new file mode 100644
index 00000000..48c48b48
--- /dev/null
+++ b/SRC/cgehrd.f
@@ -0,0 +1,273 @@
+      SUBROUTINE CGEHRD( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEHRD 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 CGEBAL; 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 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 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 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 CGEHRD
+*  subroutine incorporating improvements proposed by Quintana-Orti and
+*  Van de Geijn (2005). 
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+      COMPLEX            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ), 
+     $                     ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NH, NX
+      COMPLEX            EI
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            T( LDT, NBMAX )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CGEHD2, CGEMM, CLAHR2, CLARFB, CTRMM,
+     $                   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, 'CGEHRD', ' ', 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( 'CGEHRD', -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, 'CGEHRD', ' ', 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, 'CGEHRD', ' ', 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, 'CGEHRD', ' ', 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 CLAHR2( 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 CGEMM( '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 CTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                  'Unit', I, IB-1,
+     $                  ONE, A( I+1, I ), LDA, WORK, LDWORK )
+            DO 30 J = 0, IB-2
+               CALL CAXPY( 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 CLARFB( '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 CGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
+      WORK( 1 ) = IWS
+*
+      RETURN
+*
+*     End of CGEHRD
+*
+      END
diff --git a/SRC/cgelq2.f b/SRC/cgelq2.f
new file mode 100644
index 00000000..46047291
--- /dev/null
+++ b/SRC/cgelq2.f
@@ -0,0 +1,123 @@
+      SUBROUTINE CGELQ2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGELQ2 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, CLARFP, 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( 'CGELQ2', -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 CLACGV( N-I+1, A( I, I ), LDA )
+         ALPHA = A( I, I )
+         CALL CLARFP( 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 CLARF( '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 CLACGV( N-I+1, A( I, I ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of CGELQ2
+*
+      END
diff --git a/SRC/cgelqf.f b/SRC/cgelqf.f
new file mode 100644
index 00000000..7f6bd73e
--- /dev/null
+++ b/SRC/cgelqf.f
@@ -0,0 +1,195 @@
+      SUBROUTINE CGELQF( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGELQF 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX 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           CGELQ2, CLARFB, CLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'CGELQF', ' ', 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( 'CGELQF', -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, 'CGELQF', ' ', 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, 'CGELQF', ' ', 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 CGELQ2( 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 CLARFT( '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 CLARFB( '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 CGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of CGELQF
+*
+      END
diff --git a/SRC/cgels.f b/SRC/cgels.f
new file mode 100644
index 00000000..30f4d5c0
--- /dev/null
+++ b/SRC/cgels.f
@@ -0,0 +1,423 @@
+      SUBROUTINE CGELS( 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 ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGELS solves overdetermined or underdetermined complex linear systems
+*  involving an M-by-N matrix A, or its conjugate-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 = 'C' and m >= n:  find the minimum norm solution of
+*     an undetermined system A**H * X = B.
+*
+*  4. If TRANS = 'C' and m < n:  find the least squares solution of
+*     an overdetermined system, i.e., solve the least squares problem
+*                  minimize || B - A**H * 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;
+*          = 'C': the linear system involves A**H.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*            if M >= N, A is overwritten by details of its QR
+*                       factorization as returned by CGEQRF;
+*            if M <  N, A is overwritten by details of its LQ
+*                       factorization as returned by CGELQF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX 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 = 'C'.
+*          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 the
+*          modulus 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 = 'C' and m >= n, rows 1 to M of B contain the
+*          minimum norm solution vectors;
+*          if TRANS = 'C' 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 the modulus 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) COMPLEX 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, TPSD
+      INTEGER            BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
+      REAL               ANRM, BIGNUM, BNRM, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               RWORK( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGELQF, CGEQRF, CLASCL, CLASET, CTRTRS, CUNMLQ,
+     $                   CUNMQR, SLABAD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'C' ) ) ) 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, 'CGEQRF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'CUNMQR', 'LN', M, NRHS, N,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'CUNMQR', 'LC', M, NRHS, N,
+     $              -1 ) )
+            END IF
+         ELSE
+            NB = ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'CUNMLQ', 'LC', N, NRHS, M,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'CUNMLQ', 'LN', N, NRHS, M,
+     $              -1 ) )
+            END IF
+         END IF
+*
+         WSIZE = MAX( 1, MN + MAX( MN, NRHS )*NB )
+         WORK( 1 ) = REAL( WSIZE )
+*
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGELS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         CALL CLASET( 'Full', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         GO TO 50
+      END IF
+*
+      BROW = M
+      IF( TPSD )
+     $   BROW = N
+      BNRM = CLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CGEQRF( 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 CUNMQR( 'Left', 'Conjugate 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 CTRTRS( '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 CTRTRS( 'Upper', 'Conjugate 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 ) = CZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+            CALL CUNMQR( '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 CGELQF( 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 CTRTRS( '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 ) = CZERO
+   30          CONTINUE
+   40       CONTINUE
+*
+*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
+*
+            CALL CUNMLQ( 'Left', 'Conjugate 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 CUNMLQ( '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 CTRTRS( 'Lower', 'Conjugate 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 CLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+*
+   50 CONTINUE
+      WORK( 1 ) = REAL( WSIZE )
+*
+      RETURN
+*
+*     End of CGELS
+*
+      END
diff --git a/SRC/cgelsd.f b/SRC/cgelsd.f
new file mode 100644
index 00000000..073c79e9
--- /dev/null
+++ b/SRC/cgelsd.f
@@ -0,0 +1,571 @@
+      SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+     $                   WORK, LWORK, RWORK, IWORK, 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), S( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGELSD computes the minimum-norm solution to a real linear least
+*  squares problem:
+*      minimize 2-norm(| b - A*x |)
+*  using the singular value decomposition (SVD) of A. A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The problem is solved in three steps:
+*  (1) Reduce the coefficient matrix A to bidiagonal form with
+*      Householder tranformations, reducing the original problem
+*      into a "bidiagonal least squares problem" (BLS)
+*  (2) Solve the BLS using a divide and conquer approach.
+*  (3) Apply back all the Householder tranformations to solve
+*      the original least squares problem.
+*
+*  The effective rank of A is determined by treating as zero those
+*  singular values which are less than RCOND times the largest singular
+*  value.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX 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 the modulus of elements n+1:m in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,M,N).
+*
+*  S       (output) REAL 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) REAL
+*          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) COMPLEX 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 must be at least 1.
+*          The exact minimum amount of workspace needed depends on M,
+*          N and NRHS. As long as LWORK is at least
+*              2 * N + N * NRHS
+*          if M is greater than or equal to N or
+*              2 * M + M * NRHS
+*          if M is less than N, the code will execute correctly.
+*          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 array WORK and the
+*          minimum sizes of the arrays RWORK and IWORK, and returns
+*          these values as the first entries of the WORK, RWORK and
+*          IWORK arrays, and no error message related to LWORK is issued
+*          by XERBLA.
+*
+*  RWORK   (workspace) REAL array, dimension (MAX(1,LRWORK))
+*          LRWORK >=
+*             10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
+*             (SMLSIZ+1)**2
+*          if M is greater than or equal to N or
+*             10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
+*             (SMLSIZ+1)**2
+*          if M is less than N, the code will execute correctly.
+*          SMLSIZ is returned by ILAENV and is equal to the maximum
+*          size of the subproblems at the bottom of the computation
+*          tree (usually about 25), and
+*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+*          On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
+*          where MINMN = MIN( M,N ).
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
+     $                   LDWORK, LIWORK, LRWORK, MAXMN, MAXWRK, MINMN,
+     $                   MINWRK, MM, MNTHR, NLVL, NRWORK, NWORK, SMLSIZ
+      REAL               ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEBRD, CGELQF, CGEQRF, CLACPY,
+     $                   CLALSD, CLASCL, CLASET, CUNMBR,
+     $                   CUNMLQ, CUNMQR, SLABAD, SLASCL,
+     $                   SLASET, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           CLANGE, SLAMCH, ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, LOG, MAX, MIN, REAL
+*     ..
+*     .. 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
+         LIWORK = 1
+         LRWORK = 1
+         IF( MINMN.GT.0 ) THEN
+            SMLSIZ = ILAENV( 9, 'CGELSD', ' ', 0, 0, 0, 0 )
+            MNTHR = ILAENV( 6, 'CGELSD', ' ', M, N, NRHS, -1 )
+            NLVL = MAX( INT( LOG( REAL( MINMN ) / REAL( SMLSIZ + 1 ) ) /
+     $                  LOG( TWO ) ) + 1, 0 )
+            LIWORK = 3*MINMN*NLVL + 11*MINMN
+            MM = M
+            IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+*              Path 1a - overdetermined, with many more rows than
+*                        columns.
+*
+               MM = N
+               MAXWRK = MAX( MAXWRK, N*ILAENV( 1, 'CGEQRF', ' ', M, N,
+     $                       -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, NRHS*ILAENV( 1, 'CUNMQR', 'LC', M,
+     $                       NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined.
+*
+               LRWORK = 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
+     $                  ( SMLSIZ + 1 )**2
+               MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1,
+     $                       'CGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'CUNMBR',
+     $                       'QLC', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'CUNMBR', 'PLN', N, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + N*NRHS )
+               MINWRK = MAX( 2*N + MM, 2*N + N*NRHS )
+            END IF
+            IF( N.GT.M ) THEN
+               LRWORK = 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
+     $                  ( SMLSIZ + 1 )**2
+               IF( N.GE.MNTHR ) THEN
+*
+*                 Path 2a - underdetermined, with many more columns
+*                           than rows.
+*
+                  MAXWRK = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+     $                          'CGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+     $                          'CUNMBR', 'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
+     $                          'CUNMLQ', 'LC', N, NRHS, M, -1 ) )
+                  IF( NRHS.GT.1 ) THEN
+                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+                  ELSE
+                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
+                  END IF
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + M*NRHS )
+!     XXX: Ensure the Path 2a case below is triggered.  The workspace
+!     calculation should use queries for all routines eventually.
+                  MAXWRK = MAX( MAXWRK,
+     $                 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) )
+               ELSE
+*
+*                 Path 2 - underdetermined.
+*
+                  MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'CGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'CUNMBR',
+     $                          'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'CUNMBR',
+     $                          'PLN', N, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M + M*NRHS )
+               END IF
+               MINWRK = MAX( 2*M + N, 2*M + M*NRHS )
+            END IF
+         END IF
+         MINWRK = MIN( MINWRK, MAXWRK )
+         WORK( 1 ) = MAXWRK
+         IWORK( 1 ) = LIWORK
+         RWORK( 1 ) = LRWORK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGELSD', -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 = SLAMCH( 'P' )
+      SFMIN = SLAMCH( 'S' )
+      SMLNUM = SFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A if max entry outside range [SMLNUM,BIGNUM].
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+         RANK = 0
+         GO TO 10
+      END IF
+*
+*     Scale B if max entry outside range [SMLNUM,BIGNUM].
+*
+      BNRM = CLANGE( 'M', M, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM.
+*
+         CALL CLASCL( '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 CLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     If M < N make sure B(M+1:N,:) = 0
+*
+      IF( M.LT.N )
+     $   CALL CLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
+*
+*     Overdetermined case.
+*
+      IF( M.GE.N ) THEN
+*
+*        Path 1 - overdetermined or exactly determined.
+*
+         MM = M
+         IF( M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns
+*
+            MM = N
+            ITAU = 1
+            NWORK = ITAU + N
+*
+*           Compute A=Q*R.
+*           (RWorkspace: need N)
+*           (CWorkspace: need N, prefer N*NB)
+*
+            CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                   LWORK-NWORK+1, INFO )
+*
+*           Multiply B by transpose(Q).
+*           (RWorkspace: need N)
+*           (CWorkspace: need NRHS, prefer NRHS*NB)
+*
+            CALL CUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*           Zero out below R.
+*
+            IF( N.GT.1 ) THEN
+               CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+            END IF
+         END IF
+*
+         ITAUQ = 1
+         ITAUP = ITAUQ + N
+         NWORK = ITAUP + N
+         IE = 1
+         NRWORK = IE + N
+*
+*        Bidiagonalize R in A.
+*        (RWorkspace: need N)
+*        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
+*
+         CALL CGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R.
+*        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
+*
+         CALL CUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL CLALSD( 'U', SMLSIZ, N, NRHS, S, RWORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
+     $                IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of R.
+*
+         CALL CUNMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+     $         MAX( M, 2*M-4, NRHS, N-3*M ) ) 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
+         NWORK = M + 1
+*
+*        Compute A=L*Q.
+*        (CWorkspace: need 2*M, prefer M+M*NB)
+*
+         CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+         IL = NWORK
+*
+*        Copy L to WORK(IL), zeroing out above its diagonal.
+*
+         CALL CLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         ITAUQ = IL + LDWORK*M
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+         IE = 1
+         NRWORK = IE + M
+*
+*        Bidiagonalize L in WORK(IL).
+*        (RWorkspace: need M)
+*        (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB)
+*
+         CALL CGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L.
+*        (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+         CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUQ ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL CLALSD( 'U', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
+     $                IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of L.
+*
+         CALL CUNMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUP ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Zero out below first M rows of B.
+*
+         CALL CLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
+         NWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B.
+*        (CWorkspace: need NRHS, prefer NRHS*NB)
+*
+         CALL CUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases.
+*
+         ITAUQ = 1
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+         IE = 1
+         NRWORK = IE + M
+*
+*        Bidiagonalize A.
+*        (RWorkspace: need M)
+*        (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
+*
+         CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors.
+*        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
+*
+         CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL CLALSD( 'L', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
+     $                IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of A.
+*
+         CALL CUNMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      END IF
+*
+*     Undo scaling.
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   10 CONTINUE
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWORK
+      RWORK( 1 ) = LRWORK
+      RETURN
+*
+*     End of CGELSD
+*
+      END
diff --git a/SRC/cgelss.f b/SRC/cgelss.f
new file mode 100644
index 00000000..005f87d5
--- /dev/null
+++ b/SRC/cgelss.f
@@ -0,0 +1,634 @@
+      SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * ), S( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGELSS computes the minimum norm solution to a complex 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) COMPLEX 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) COMPLEX 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 the modulus of elements n+1:m in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,M,N).
+*
+*  S       (output) REAL 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) REAL
+*          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) COMPLEX 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 >=  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.
+*
+*  RWORK   (workspace) REAL array, dimension (5*min(M,N))
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            BL, CHUNK, I, IASCL, IBSCL, IE, IL, IRWORK,
+     $                   ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
+     $                   MAXWRK, MINMN, MINWRK, MM, MNTHR
+      REAL               ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            VDUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CBDSQR, CCOPY, CGEBRD, CGELQF, CGEMM, CGEMV,
+     $                   CGEQRF, CLACPY, CLASCL, CLASET, CSRSCL, CUNGBR,
+     $                   CUNMBR, CUNMLQ, CUNMQR, SLABAD, SLASCL, SLASET,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. 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.
+*       CWorkspace refers to complex workspace, and RWorkspace refers
+*       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( MINMN.GT.0 ) THEN
+            MM = M
+            MNTHR = ILAENV( 6, 'CGELSS', ' ', 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, 'CGEQRF', ' ', M,
+     $                       N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'CUNMQR', 'LC',
+     $                       M, NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined
+*
+               MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1,
+     $                       'CGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'CUNMBR',
+     $                       'QLC', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'CUNGBR', 'P', N, N, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, N*NRHS )
+               MINWRK = 2*N + MAX( NRHS, M )
+            END IF
+            IF( N.GT.M ) THEN
+               MINWRK = 2*M + MAX( NRHS, N )
+               IF( N.GE.MNTHR ) THEN
+*
+*                 Path 2a - underdetermined, with many more columns
+*                 than rows
+*
+                  MAXWRK = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*M + 2*M*ILAENV( 1,
+     $                          'CGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*M + NRHS*ILAENV( 1,
+     $                          'CUNMBR', 'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*M + ( M - 1 )*ILAENV( 1,
+     $                          'CUNGBR', 'P', M, M, M, -1 ) )
+                  IF( NRHS.GT.1 ) THEN
+                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+                  ELSE
+                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
+                  END IF
+                  MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'CUNMLQ',
+     $                          'LC', N, NRHS, M, -1 ) )
+               ELSE
+*
+*                 Path 2 - underdetermined
+*
+                  MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'CGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'CUNMBR',
+     $                          'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'CUNGBR',
+     $                          'P', M, N, M, -1 ) )
+                  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( 'CGELSS', -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 = SLAMCH( 'P' )
+      SFMIN = SLAMCH( 'S' )
+      SMLNUM = SFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, MINMN )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = CLANGE( 'M', M, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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
+*           (CWorkspace: need 2*N, prefer N+N*NB)
+*           (RWorkspace: none)
+*
+            CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                   LWORK-IWORK+1, INFO )
+*
+*           Multiply B by transpose(Q)
+*           (CWorkspace: need N+NRHS, prefer N+NRHS*NB)
+*           (RWorkspace: none)
+*
+            CALL CUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*           Zero out below R
+*
+            IF( N.GT.1 )
+     $         CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+         END IF
+*
+         IE = 1
+         ITAUQ = 1
+         ITAUP = ITAUQ + N
+         IWORK = ITAUP + N
+*
+*        Bidiagonalize R in A
+*        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
+*        (RWorkspace: need N)
+*
+         CALL CGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R
+*        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors of R in A
+*        (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IRWORK = IE + N
+*
+*        Perform bidiagonal QR iteration
+*          multiply B by transpose of left singular vectors
+*          compute right singular vectors in A
+*        (CWorkspace: none)
+*        (RWorkspace: need BDSPAC)
+*
+         CALL CBDSQR( 'U', N, N, 0, NRHS, S, RWORK( IE ), A, LDA, VDUM,
+     $                1, B, LDB, RWORK( IRWORK ), 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 CSRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL CLASET( 'F', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            END IF
+   10    CONTINUE
+*
+*        Multiply B by right singular vectors
+*        (CWorkspace: need N, prefer N*NRHS)
+*        (RWorkspace: none)
+*
+         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+            CALL CGEMM( 'C', 'N', N, NRHS, N, CONE, A, LDA, B, LDB,
+     $                  CZERO, WORK, LDB )
+            CALL CLACPY( '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 CGEMM( 'C', 'N', N, BL, N, CONE, A, LDA, B( 1, I ),
+     $                     LDB, CZERO, WORK, N )
+               CALL CLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
+   20       CONTINUE
+         ELSE
+            CALL CGEMV( 'C', N, N, CONE, A, LDA, B, 1, CZERO, WORK, 1 )
+            CALL CCOPY( N, WORK, 1, B, 1 )
+         END IF
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.3*M+M*M+MAX( M, NRHS, N-2*M ) )
+     $          THEN
+*
+*        Underdetermined case, M much less than N
+*
+*        Path 2a - underdetermined, with many more columns than rows
+*        and sufficient workspace for an efficient algorithm
+*
+         LDWORK = M
+         IF( LWORK.GE.3*M+M*LDA+MAX( M, NRHS, N-2*M ) )
+     $      LDWORK = LDA
+         ITAU = 1
+         IWORK = M + 1
+*
+*        Compute A=L*Q
+*        (CWorkspace: need 2*M, prefer M+M*NB)
+*        (RWorkspace: none)
+*
+         CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+         IL = IWORK
+*
+*        Copy L to WORK(IL), zeroing out above it
+*
+         CALL CLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         IE = 1
+         ITAUQ = IL + LDWORK*M
+         ITAUP = ITAUQ + M
+         IWORK = ITAUP + M
+*
+*        Bidiagonalize L in WORK(IL)
+*        (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*        (RWorkspace: need M)
+*
+         CALL CGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L
+*        (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNMBR( 'Q', 'L', 'C', 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)
+*        (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IRWORK = IE + M
+*
+*        Perform bidiagonal QR iteration, computing right singular
+*        vectors of L in WORK(IL) and multiplying B by transpose of
+*        left singular vectors
+*        (CWorkspace: need M*M)
+*        (RWorkspace: need BDSPAC)
+*
+         CALL CBDSQR( 'U', M, M, 0, NRHS, S, RWORK( IE ), WORK( IL ),
+     $                LDWORK, A, LDA, B, LDB, RWORK( IRWORK ), 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 CSRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL CLASET( 'F', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            END IF
+   30    CONTINUE
+         IWORK = IL + M*LDWORK
+*
+*        Multiply B by right singular vectors of L in WORK(IL)
+*        (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS)
+*        (RWorkspace: none)
+*
+         IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
+            CALL CGEMM( 'C', 'N', M, NRHS, M, CONE, WORK( IL ), LDWORK,
+     $                  B, LDB, CZERO, WORK( IWORK ), LDB )
+            CALL CLACPY( '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 CGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK,
+     $                     B( 1, I ), LDB, CZERO, WORK( IWORK ), M )
+               CALL CLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
+     $                      LDB )
+   40       CONTINUE
+         ELSE
+            CALL CGEMV( 'C', M, M, CONE, WORK( IL ), LDWORK, B( 1, 1 ),
+     $                  1, CZERO, WORK( IWORK ), 1 )
+            CALL CCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
+         END IF
+*
+*        Zero out below first M rows of B
+*
+         CALL CLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
+         IWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B
+*        (CWorkspace: need M+NRHS, prefer M+NHRS*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases
+*
+         IE = 1
+         ITAUQ = 1
+         ITAUP = ITAUQ + M
+         IWORK = ITAUP + M
+*
+*        Bidiagonalize A
+*        (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB)
+*        (RWorkspace: need N)
+*
+         CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors
+*        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors in A
+*        (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*        (RWorkspace: none)
+*
+         CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IRWORK = IE + M
+*
+*        Perform bidiagonal QR iteration,
+*           computing right singular vectors of A in A and
+*           multiplying B by transpose of left singular vectors
+*        (CWorkspace: none)
+*        (RWorkspace: need BDSPAC)
+*
+         CALL CBDSQR( 'L', M, N, 0, NRHS, S, RWORK( IE ), A, LDA, VDUM,
+     $                1, B, LDB, RWORK( IRWORK ), 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 CSRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL CLASET( 'F', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            END IF
+   50    CONTINUE
+*
+*        Multiply B by right singular vectors of A
+*        (CWorkspace: need N, prefer N*NRHS)
+*        (RWorkspace: none)
+*
+         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+            CALL CGEMM( 'C', 'N', N, NRHS, M, CONE, A, LDA, B, LDB,
+     $                  CZERO, WORK, LDB )
+            CALL CLACPY( 'G', 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 CGEMM( 'C', 'N', N, BL, M, CONE, A, LDA, B( 1, I ),
+     $                     LDB, CZERO, WORK, N )
+               CALL CLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
+   60       CONTINUE
+         ELSE
+            CALL CGEMV( 'C', M, N, CONE, A, LDA, B, 1, CZERO, WORK, 1 )
+            CALL CCOPY( N, WORK, 1, B, 1 )
+         END IF
+      END IF
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+   70 CONTINUE
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of CGELSS
+*
+      END
diff --git a/SRC/cgelsx.f b/SRC/cgelsx.f
new file mode 100644
index 00000000..f809ff95
--- /dev/null
+++ b/SRC/cgelsx.f
@@ -0,0 +1,357 @@
+      SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+     $                   WORK, 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, M, N, NRHS, RANK
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine CGELSY.
+*
+*  CGELSX 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.
+*
+*  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 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 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) REAL
+*          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) COMPLEX array, dimension
+*                      (min(M,N) + max( N, 2*min(M,N)+NRHS )),
+*
+*  RWORK   (workspace) REAL array, dimension (2*N)
+*
+*  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 )
+      REAL               ZERO, ONE, DONE, NTDONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, DONE = ZERO,
+     $                   NTDONE = ONE )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
+      REAL               ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
+     $                   SMLNUM
+      COMPLEX            C1, C2, S1, S2, T1, T2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQPF, CLAIC1, CLASCL, CLASET, CLATZM, CTRSM,
+     $                   CTZRQF, CUNM2R, SLABAD, XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           CLANGE, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, 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( 'CGELSX', -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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max elements outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         RANK = 0
+         GO TO 100
+      END IF
+*
+      BNRM = CLANGE( 'M', M, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), RWORK,
+     $             INFO )
+*
+*     complex workspace MN+N. 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 CLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         GO TO 100
+      ELSE
+         RANK = 1
+      END IF
+*
+   10 CONTINUE
+      IF( RANK.LT.MN ) THEN
+         I = RANK + 1
+         CALL CLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL CLAIC1( 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 CTZRQF( 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 CUNM2R( 'Left', 'Conjugate 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 CTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+     $            NRHS, CONE, A, LDA, B, LDB )
+*
+      DO 40 I = RANK + 1, N
+         DO 30 J = 1, NRHS
+            B( I, J ) = CZERO
+   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 CLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
+     $                   CONJG( 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 CLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL CLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL CLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of CGELSX
+*
+      END
diff --git a/SRC/cgelsy.f b/SRC/cgelsy.f
new file mode 100644
index 00000000..77ae7fa8
--- /dev/null
+++ b/SRC/cgelsy.f
@@ -0,0 +1,385 @@
+      SUBROUTINE CGELSY( 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGELSY 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 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 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) REAL
+*          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 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 CGEQP3, CTZRZF, CTZRQF, CUNMQR,
+*          and CUNMRZ.
+*
+*          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) REAL 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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKOPT, MN,
+     $                   NB, NB1, NB2, NB3, NB4
+      REAL               ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
+     $                   SMLNUM, WSIZE
+      COMPLEX            C1, C2, S1, S2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEQP3, CLAIC1, CLASCL, CLASET, CTRSM,
+     $                   CTZRZF, CUNMQR, CUNMRZ, SLABAD, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           CLANGE, ILAENV, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, CMPLX
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M, N )
+      ISMIN = MN + 1
+      ISMAX = 2*MN + 1
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'CGERQF', ' ', M, N, -1, -1 )
+      NB3 = ILAENV( 1, 'CUNMQR', ' ', M, N, NRHS, -1 )
+      NB4 = ILAENV( 1, 'CUNMRQ', ' ', 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 ) = CMPLX( 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( 'CGELSY', -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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+      BNRM = CLANGE( 'M', M, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL CLASCL( '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 CLASCL( '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 CGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
+     $             LWORK-MN, RWORK, INFO )
+      WSIZE = MN + REAL( 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 CLASET( '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 CLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL CLAIC1( 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 CTZRZF( 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 CUNMQR( '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+REAL( WORK( 2*MN+1 ) ) )
+*
+*     complex workspace: 2*MN+NB*NRHS.
+*
+*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+      CALL CTRSM( '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 CUNMRZ( '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 CCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+   60 CONTINUE
+*
+*     complex workspace: N.
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL CLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL CLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL CLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL CLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = CMPLX( LWKOPT )
+*
+      RETURN
+*
+*     End of CGELSY
+*
+      END
diff --git a/SRC/cgeql2.f b/SRC/cgeql2.f
new file mode 100644
index 00000000..57c517a7
--- /dev/null
+++ b/SRC/cgeql2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE CGEQL2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEQL2 computes a QL factorization of a complex 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) COMPLEX 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
+*          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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX 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 complex scalar, and v is a complex 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 ..
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CLARFP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CGEQL2', -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)
+*
+         ALPHA = A( M-K+I, N-K+I )
+         CALL CLARFP( M-K+I, ALPHA, 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
+*
+         A( M-K+I, N-K+I ) = ONE
+         CALL CLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
+     $               CONJG( TAU( I ) ), A, LDA, WORK )
+         A( M-K+I, N-K+I ) = ALPHA
+   10 CONTINUE
+      RETURN
+*
+*     End of CGEQL2
+*
+      END
diff --git a/SRC/cgeqlf.f b/SRC/cgeqlf.f
new file mode 100644
index 00000000..11c131df
--- /dev/null
+++ b/SRC/cgeqlf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE CGEQLF( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEQLF computes a QL factorization of a complex 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) COMPLEX 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
+*          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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX 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 complex scalar, and v is a complex 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           CGEQL2, CLARFB, CLARFT, 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, 'CGEQLF', ' ', 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( 'CGEQLF', -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, 'CGEQLF', ' ', 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, 'CGEQLF', ' ', 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 CGEQL2( 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 CLARFT( '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 CLARFB( 'Left', 'Conjugate 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 CGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of CGEQLF
+*
+      END
diff --git a/SRC/cgeqp3.f b/SRC/cgeqp3.f
new file mode 100644
index 00000000..548123e1
--- /dev/null
+++ b/SRC/cgeqp3.f
@@ -0,0 +1,293 @@
+      SUBROUTINE CGEQP3( 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( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEQP3 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) COMPLEX 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) REAL 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           CGEQRF, CLAQP2, CLAQPS, CSWAP, CUNMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SCNRM2
+      EXTERNAL           ILAENV, SCNRM2
+*     ..
+*     .. 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, 'CGEQRF', ' ', 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( 'CGEQP3', -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 CSWAP( 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 CGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
+         CALL CGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
+         IWS = MAX( IWS, INT( WORK( 1 ) ) )
+         IF( NA.LT.N ) THEN
+*CC         CALL CUNM2R( 'Left', 'Conjugate Transpose', M, N-NA,
+*CC  $                   NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK,
+*CC  $                   INFO )
+            CALL CUNMQR( '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, 'CGEQRF', ' ', 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, 'CGEQRF', ' ', 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, 'CGEQRF', ' ', 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 ) = SCNRM2( 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 CLAQPS( 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 CLAQP2( 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 CGEQP3
+*
+      END
diff --git a/SRC/cgeqpf.f b/SRC/cgeqpf.f
new file mode 100644
index 00000000..40fa83d8
--- /dev/null
+++ b/SRC/cgeqpf.f
@@ -0,0 +1,234 @@
+      SUBROUTINE CGEQPF( 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( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine CGEQP3.
+*
+*  CGEQPF 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MA, MN, PVT
+      REAL               TEMP, TEMP2, TOL3Z
+      COMPLEX            AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQR2, CLARF, CLARFG, CSWAP, CUNM2R, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CMPLX, CONJG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SCNRM2, SLAMCH
+      EXTERNAL           ISAMAX, SCNRM2, SLAMCH
+*     ..
+*     .. 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( 'CGEQPF', -INFO )
+         RETURN
+      END IF
+*
+      MN = MIN( M, N )
+      TOL3Z = SQRT(SLAMCH('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 CSWAP( 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 CGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+         IF( MA.LT.N ) THEN
+            CALL CUNM2R( '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 ) = SCNRM2( 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 ) + ISAMAX( N-I+1, RWORK( I ), 1 )
+*
+            IF( PVT.NE.I ) THEN
+               CALL CSWAP( 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 CLARFG( 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 ) = CMPLX( ONE )
+               CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                     CONJG( 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 ) = SCNRM2( 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 CGEQPF
+*
+      END
diff --git a/SRC/cgeqr2.f b/SRC/cgeqr2.f
new file mode 100644
index 00000000..df7c44a0
--- /dev/null
+++ b/SRC/cgeqr2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE CGEQR2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEQR2 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CLARFP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CGEQR2', -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 CLARFP( 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 CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                  CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
+            A( I, I ) = ALPHA
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of CGEQR2
+*
+      END
diff --git a/SRC/cgeqrf.f b/SRC/cgeqrf.f
new file mode 100644
index 00000000..6cd3282a
--- /dev/null
+++ b/SRC/cgeqrf.f
@@ -0,0 +1,196 @@
+      SUBROUTINE CGEQRF( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGEQRF 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX 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           CGEQR2, CLARFB, CLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'CGEQRF', ' ', 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( 'CGEQRF', -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, 'CGEQRF', ' ', 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, 'CGEQRF', ' ', 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 CGEQR2( 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 CLARFT( '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 CLARFB( '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 CGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of CGEQRF
+*
+      END
diff --git a/SRC/cgerfs.f b/SRC/cgerfs.f
new file mode 100644
index 00000000..f958f9d5
--- /dev/null
+++ b/SRC/cgerfs.f
@@ -0,0 +1,345 @@
+      SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGERFS 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)
+*
+*  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) COMPLEX 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) COMPLEX array, dimension (LDAF,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by CGETRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from CGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CGETRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMV, CGETRS, CLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CGERFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( '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 CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK,
+     $               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
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               DO 60 I = 1, N
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 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 CLACN2 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( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL CGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK, N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CGETRS( TRANSN, N, 1, AF, LDAF, IPIV, WORK, N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CGERFS
+*
+      END
diff --git a/SRC/cgerq2.f b/SRC/cgerq2.f
new file mode 100644
index 00000000..0ac136f2
--- /dev/null
+++ b/SRC/cgerq2.f
@@ -0,0 +1,124 @@
+      SUBROUTINE CGERQ2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGERQ2 computes an RQ factorization of a complex 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) COMPLEX 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX 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 complex scalar, and v is a complex vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(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 ..
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, CLARFP, 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( 'CGERQ2', -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 CLACGV( N-K+I, A( M-K+I, 1 ), LDA )
+         ALPHA = A( M-K+I, N-K+I )
+         CALL CLARFP( N-K+I, ALPHA, 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
+*
+         A( M-K+I, N-K+I ) = ONE
+         CALL CLARF( '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 ) = ALPHA
+         CALL CLACGV( N-K+I-1, A( M-K+I, 1 ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of CGERQ2
+*
+      END
diff --git a/SRC/cgerqf.f b/SRC/cgerqf.f
new file mode 100644
index 00000000..a507f820
--- /dev/null
+++ b/SRC/cgerqf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE CGERQF( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGERQF computes an RQ factorization of a complex 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) COMPLEX 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
+*          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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX 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 complex scalar, and v is a complex vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(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           CGERQ2, CLARFB, CLARFT, 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, 'CGERQF', ' ', 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( 'CGERQF', -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, 'CGERQF', ' ', 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, 'CGERQF', ' ', 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 CGERQ2( 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 CLARFT( '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 CLARFB( '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 CGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of CGERQF
+*
+      END
diff --git a/SRC/cgesc2.f b/SRC/cgesc2.f
new file mode 100644
index 00000000..a70cbe30
--- /dev/null
+++ b/SRC/cgesc2.f
@@ -0,0 +1,133 @@
+      SUBROUTINE CGESC2( 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
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      COMPLEX            A( LDA, * ), RHS( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGESC2 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 CGETC2.
+*
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.
+*
+*  A       (input) COMPLEX array, dimension (LDA, N)
+*          On entry, the  LU part of the factorization of the n-by-n
+*          matrix A computed by CGETC2:  A = P * L * U * Q
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1, N).
+*
+*  RHS     (input/output) COMPLEX 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) REAL
+*           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 ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               BIGNUM, EPS, SMLNUM
+      COMPLEX            TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASWP, CSCAL, SLABAD
+*     ..
+*     .. External Functions ..
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      EXTERNAL           ICAMAX, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CMPLX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Set constant to control overflow
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Apply permutations IPIV to RHS
+*
+      CALL CLASWP( 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 = ICAMAX( N, RHS, 1 )
+      IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
+         TEMP = CMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) )
+         CALL CSCAL( N, TEMP, RHS( 1 ), 1 )
+         SCALE = SCALE*REAL( TEMP )
+      END IF
+      DO 40 I = N, 1, -1
+         TEMP = CMPLX( 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 CLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
+      RETURN
+*
+*     End of CGESC2
+*
+      END
diff --git a/SRC/cgesdd.f b/SRC/cgesdd.f
new file mode 100644
index 00000000..6bbf697f
--- /dev/null
+++ b/SRC/cgesdd.f
@@ -0,0 +1,1962 @@
+      SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT,
+     $                   WORK, LWORK, RWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*     8-15-00:  Improve consistency of WS calculations (eca)
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ
+      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), S( * )
+      COMPLEX            A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGESDD computes the singular value decomposition (SVD) of a complex
+*  M-by-N matrix A, optionally computing the left and/or right singular
+*  vectors, by using divide-and-conquer method. 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 VT = V**H, not V.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix U:
+*          = 'A':  all M columns of U and all N rows of V**H are
+*                  returned in the arrays U and VT;
+*          = 'S':  the first min(M,N) columns of U and the first
+*                  min(M,N) rows of V**H are returned in the arrays U
+*                  and VT;
+*          = 'O':  If M >= N, the first N columns of U are overwritten
+*                  in the array A and all rows of V**H are returned in
+*                  the array VT;
+*                  otherwise, all columns of U are returned in the
+*                  array U and the first M rows of V**H are overwritten
+*                  in the array A;
+*          = 'N':  no columns of U or rows of V**H are computed.
+*
+*  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 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*          if JOBZ = 'O',  A is overwritten with the first N columns
+*                          of U (the left singular vectors, stored
+*                          columnwise) if M >= N;
+*                          A is overwritten with the first M rows
+*                          of V**H (the right singular vectors, stored
+*                          rowwise) otherwise.
+*          if JOBZ .ne. 'O', the contents of A are destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  S       (output) REAL array, dimension (min(M,N))
+*          The singular values of A, sorted so that S(i) >= S(i+1).
+*
+*  U       (output) COMPLEX array, dimension (LDU,UCOL)
+*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
+*          UCOL = min(M,N) if JOBZ = 'S'.
+*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
+*          unitary matrix U;
+*          if JOBZ = 'S', U contains the first min(M,N) columns of U
+*          (the left singular vectors, stored columnwise);
+*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1; if
+*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
+*
+*  VT      (output) COMPLEX array, dimension (LDVT,N)
+*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
+*          N-by-N unitary matrix V**H;
+*          if JOBZ = 'S', VT contains the first min(M,N) rows of
+*          V**H (the right singular vectors, stored rowwise);
+*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1; if
+*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
+*          if JOBZ = 'S', LDVT >= min(M,N).
+*
+*  WORK    (workspace/output) COMPLEX 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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).
+*          if JOBZ = 'O',
+*                LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
+*          if JOBZ = 'S' or 'A',
+*                LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, a workspace query is assumed.  The optimal
+*          size for the WORK array is calculated and stored in WORK(1),
+*          and no other work except argument checking is performed.
+*
+*  RWORK   (workspace) REAL array, dimension (MAX(1,LRWORK))
+*          If JOBZ = 'N', LRWORK >= 5*min(M,N).
+*          Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 7*min(M,N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The updating process of SBDSDC did not converge.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            LQUERV
+      PARAMETER          ( LQUERV = -1 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
+      INTEGER            BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT,
+     $                   ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
+     $                   LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
+     $                   MNTHR1, MNTHR2, NRWORK, NWORK, WRKBL
+      REAL               ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEBRD, CGELQF, CGEMM, CGEQRF, CLACP2, CLACPY,
+     $                   CLACRM, CLARCM, CLASCL, CLASET, CUNGBR, CUNGLQ,
+     $                   CUNGQR, CUNMBR, SBDSDC, SLASCL, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           CLANGE, SLAMCH, ILAENV, LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      MNTHR1 = INT( MINMN*17.0 / 9.0 )
+      MNTHR2 = INT( MINMN*5.0 / 3.0 )
+      WNTQA = LSAME( JOBZ, 'A' )
+      WNTQS = LSAME( JOBZ, 'S' )
+      WNTQAS = WNTQA .OR. WNTQS
+      WNTQO = LSAME( JOBZ, 'O' )
+      WNTQN = LSAME( JOBZ, 'N' )
+      MINWRK = 1
+      MAXWRK = 1
+*
+      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
+     $         ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
+         INFO = -8
+      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
+     $         ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
+     $         ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
+         INFO = -10
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace 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 .AND. M.GT.0 .AND. N.GT.0 ) THEN
+         IF( M.GE.N ) THEN
+*
+*           There is no complex work space needed for bidiagonal SVD
+*           The real work space needed for bidiagonal SVD is BDSPAC
+*           for computing singular values and singular vectors; BDSPAN
+*           for computing singular values only.
+*           BDSPAC = 5*N*N + 7*N
+*           BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8))
+*
+            IF( M.GE.MNTHR1 ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1 (M much larger than N, JOBZ='N')
+*
+                  MAXWRK = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 2*N+2*N*
+     $                     ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  MINWRK = 3*N
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2 (M much larger than N, JOBZ='O')
+*
+                  WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = M*N + N*N + WRKBL
+                  MINWRK = 2*N*N + 3*N
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3 (M much larger than N, JOBZ='S')
+*
+                  WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = N*N + 3*N
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4 (M much larger than N, JOBZ='A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = N*N + 2*N + M
+               END IF
+            ELSE IF( M.GE.MNTHR2 ) THEN
+*
+*              Path 5 (M much larger than N, but not as much as MNTHR1)
+*
+               MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*N + M
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, N, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + N*N
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, N, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+M*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) )
+               END IF
+            ELSE
+*
+*              Path 6 (M at least N, but not much larger)
+*
+               MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*N + M
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNMBR', 'QLN', M, N, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + N*N
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNMBR', 'QLN', M, N, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+M*
+     $                     ILAENV( 1, 'CUNGBR', 'QLN', M, M, N, -1 ) )
+               END IF
+            END IF
+         ELSE
+*
+*           There is no complex work space needed for bidiagonal SVD
+*           The real work space needed for bidiagonal SVD is BDSPAC
+*           for computing singular values and singular vectors; BDSPAN
+*           for computing singular values only.
+*           BDSPAC = 5*M*M + 7*M
+*           BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8))
+*
+            IF( N.GE.MNTHR1 ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1t (N much larger than M, JOBZ='N')
+*
+                  MAXWRK = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M+2*M*
+     $                     ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  MINWRK = 3*M
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2t (N much larger than M, JOBZ='O')
+*
+                  WRKBL = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNMBR', 'PRC', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNMBR', 'QLN', M, M, M, -1 ) )
+                  MAXWRK = M*N + M*M + WRKBL
+                  MINWRK = 2*M*M + 3*M
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3t (N much larger than M, JOBZ='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNMBR', 'PRC', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNMBR', 'QLN', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = M*M + 3*M
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4t (N much larger than M, JOBZ='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'CUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNMBR', 'PRC', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNMBR', 'QLN', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = M*M + 2*M + N
+               END IF
+            ELSE IF( N.GE.MNTHR2 ) THEN
+*
+*              Path 5t (N much larger than M, but not as much as MNTHR1)
+*
+               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*M + N
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'P', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + M*M
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'P', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+N*
+     $                     ILAENV( 1, 'CUNGBR', 'P', N, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) )
+               END IF
+            ELSE
+*
+*              Path 6t (N greater than M, but not much larger)
+*
+               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'CGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*M + N
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNMBR', 'PRC', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNMBR', 'QLN', M, M, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + M*M
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'PRC', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'QLN', M, M, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+N*
+     $                     ILAENV( 1, 'CUNGBR', 'PRC', N, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'QLN', M, M, N, -1 ) )
+               END IF
+            END IF
+         END IF
+         MAXWRK = MAX( MAXWRK, MINWRK )
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = MAXWRK
+         IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV )
+     $      INFO = -13
+      END IF
+*
+*     Quick returns
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGESDD', -INFO )
+         RETURN
+      END IF
+      IF( LWORK.EQ.LQUERV )
+     $   RETURN
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL CLASCL( '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.MNTHR1 ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1 (M much larger than N, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: need 0)
+*
+               CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = 1
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*              (RWorkspace: need N)
+*
+               CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NRWORK = IE + N
+*
+*              Perform bidiagonal SVD, compute singular values only
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAN)
+*
+               CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2 (M much larger than N, JOBZ='O')
+*              N left singular vectors to be overwritten on A and
+*              N right singular vectors to be computed in VT
+*
+               IU = 1
+*
+*              WORK(IU) is N by N
+*
+               LDWRKU = N
+               IR = IU + LDWRKU*N
+               IF( LWORK.GE.M*N+N*N+3*N ) THEN
+*
+*                 WORK(IR) is M by N
+*
+                  LDWRKR = M
+               ELSE
+                  LDWRKR = ( LWORK-N*N-3*N ) / N
+               END IF
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy R to WORK( IR ), zeroing out below it
+*
+               CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+               CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, WORK( IR+1 ),
+     $                      LDWRKR )
+*
+*              Generate Q in A
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in WORK(IR)
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+2*N*NB)
+*              (RWorkspace: need N)
+*
+               CALL CGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of R in WORK(IRU) and computing right singular vectors
+*              of R in WORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + N
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by the left singular vectors of R
+*              (CWorkspace: need 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
+     $                      LDWRKU )
+               CALL CUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by the right singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IU), storing result in WORK(IR) and copying to A
+*              (CWorkspace: need 2*N*N, prefer N*N+M*N)
+*              (RWorkspace: 0)
+*
+               DO 10 I = 1, M, LDWRKR
+                  CHUNK = MIN( M-I+1, LDWRKR )
+                  CALL CGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
+     $                        LDA, WORK( IU ), LDWRKU, CZERO,
+     $                        WORK( IR ), LDWRKR )
+                  CALL CLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+     $                         A( I, 1 ), LDA )
+   10          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Path 3 (M much larger than N, JOBZ='S')
+*              N left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IR = 1
+*
+*              WORK(IR) is N by N
+*
+               LDWRKR = N
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy R to WORK(IR), zeroing out below it
+*
+               CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+               CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, WORK( IR+1 ),
+     $                      LDWRKR )
+*
+*              Generate Q in A
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + N
+               NWORK = 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 CGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + N
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IR), storing result in U
+*              (CWorkspace: need N*N)
+*              (RWorkspace: 0)
+*
+               CALL CLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
+               CALL CGEMM( 'N', 'N', M, N, N, CONE, A, LDA, WORK( IR ),
+     $                     LDWRKR, CZERO, U, LDU )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 4 (M much larger than N, JOBZ='A')
+*              M left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IU = 1
+*
+*              WORK(IU) is N by N
+*
+               LDWRKU = N
+               ITAU = IU + LDWRKU*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R, copying result to U
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*              Generate Q in U
+*              (CWorkspace: need N+M, prefer N+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce R in A, zeroing out below it
+*
+               CALL CLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*              (RWorkspace: need N)
+*
+               CALL CGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               IRU = IE + N
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by left singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
+     $                      LDWRKU )
+               CALL CUNMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
+     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of R
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in U by left singular vectors of R in
+*              WORK(IU), storing result in A
+*              (CWorkspace: need N*N)
+*              (RWorkspace: 0)
+*
+               CALL CGEMM( '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 CLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+            END IF
+*
+         ELSE IF( M.GE.MNTHR2 ) THEN
+*
+*           MNTHR2 <= M < MNTHR1
+*
+*           Path 5 (M much larger than N, but not as much as MNTHR1)
+*           Reduce to bidiagonal form without QR decomposition, use
+*           CUNGBR and matrix multiplication to compute singular vectors
+*
+            IE = 1
+            NRWORK = IE + N
+            ITAUQ = 1
+            ITAUP = ITAUQ + N
+            NWORK = ITAUP + N
+*
+*           Bidiagonalize A
+*           (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
+*           (RWorkspace: need N)
+*
+            CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IU = NWORK
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Generate Q in A
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*N ) THEN
+*
+*                 WORK( IU ) is M by N
+*
+                  LDWRKU = M
+               ELSE
+*
+*                 WORK(IU) is LDWRKU by N
+*
+                  LDWRKU = ( LWORK-3*N ) / N
+               END IF
+               NWORK = IU + LDWRKU*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in WORK(IU), copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 3*N*N)
+*
+               CALL CLARCM( N, N, RWORK( IRVT ), N, VT, LDVT,
+     $                      WORK( IU ), LDWRKU, RWORK( NRWORK ) )
+               CALL CLACPY( 'F', N, N, WORK( IU ), LDWRKU, VT, LDVT )
+*
+*              Multiply Q in A by real matrix RWORK(IRU), storing the
+*              result in WORK(IU), copying to A
+*              (CWorkspace: need N*N, prefer M*N)
+*              (Rworkspace: need 3*N*N, prefer N*N+2*M*N)
+*
+               NRWORK = IRVT
+               DO 20 I = 1, M, LDWRKU
+                  CHUNK = MIN( M-I+1, LDWRKU )
+                  CALL CLACRM( CHUNK, N, A( I, 1 ), LDA, RWORK( IRU ),
+     $                         N, WORK( IU ), LDWRKU, RWORK( NRWORK ) )
+                  CALL CLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                         A( I, 1 ), LDA )
+   20          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+               CALL CUNGBR( 'Q', M, N, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 3*N*N)
+*
+               CALL CLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: need 0)
+*              (Rworkspace: need N*N+2*M*N)
+*
+               NRWORK = IRVT
+               CALL CLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, N, A, LDA, U, LDU )
+            ELSE
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL CUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+               CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 3*N*N)
+*
+               CALL CLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: 0)
+*              (Rworkspace: need 3*N*N)
+*
+               NRWORK = IRVT
+               CALL CLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, N, A, LDA, U, LDU )
+            END IF
+*
+         ELSE
+*
+*           M .LT. MNTHR2
+*
+*           Path 6 (M at least N, but not much larger)
+*           Reduce to bidiagonal form without QR decomposition
+*           Use CUNMBR to compute singular vectors
+*
+            IE = 1
+            NRWORK = IE + N
+            ITAUQ = 1
+            ITAUP = ITAUQ + N
+            NWORK = ITAUP + N
+*
+*           Bidiagonalize A
+*           (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
+*           (RWorkspace: need N)
+*
+            CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL SBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IU = NWORK
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               IF( LWORK.GE.M*N+3*N ) THEN
+*
+*                 WORK( IU ) is M by N
+*
+                  LDWRKU = M
+               ELSE
+*
+*                 WORK( IU ) is LDWRKU by N
+*
+                  LDWRKU = ( LWORK-3*N ) / N
+               END IF
+               NWORK = IU + LDWRKU*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: need 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*N ) THEN
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by left singular vectors of A, copying
+*              to A
+*              (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB)
+*              (Rworkspace: need 0)
+*
+                  CALL CLASET( 'F', M, N, CZERO, CZERO, WORK( IU ),
+     $                         LDWRKU )
+                  CALL CLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
+     $                         LDWRKU )
+                  CALL CUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                         WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+                  CALL CLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
+               ELSE
+*
+*                 Generate Q in A
+*                 (Cworkspace: need 2*N, prefer N+N*NB)
+*                 (Rworkspace: need 0)
+*
+                  CALL CUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by real matrix RWORK(IRU), storing the
+*                 result in WORK(IU), copying to A
+*                 (CWorkspace: need N*N, prefer M*N)
+*                 (Rworkspace: need 3*N*N, prefer N*N+2*M*N)
+*
+                  NRWORK = IRVT
+                  DO 30 I = 1, M, LDWRKU
+                     CHUNK = MIN( M-I+1, LDWRKU )
+                     CALL CLACRM( CHUNK, N, A( I, 1 ), LDA,
+     $                            RWORK( IRU ), N, WORK( IU ), LDWRKU,
+     $                            RWORK( NRWORK ) )
+                     CALL CLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                            A( I, 1 ), LDA )
+   30             CONTINUE
+               END IF
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLASET( 'F', M, N, CZERO, CZERO, U, LDU )
+               CALL CLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL SBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Set the right corner of U to identity matrix
+*
+               CALL CLASET( 'F', M, M, CZERO, CZERO, U, LDU )
+               IF( M.GT.N ) THEN
+                  CALL CLASET( 'F', M-N, M-N, CZERO, CONE,
+     $                         U( N+1, N+1 ), LDU )
+               END IF
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      ELSE
+*
+*        A has more columns than rows. If A has sufficiently more
+*        columns than rows, first reduce using the LQ decomposition (if
+*        sufficient workspace available)
+*
+         IF( N.GE.MNTHR1 ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1t (N much larger than M, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = 1
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NRWORK = IE + M
+*
+*              Perform bidiagonal SVD, compute singular values only
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAN)
+*
+               CALL SBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2t (N much larger than M, JOBZ='O')
+*              M right singular vectors to be overwritten on A and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+               LDWKVT = M
+*
+*              WORK(IVT) is M by M
+*
+               IL = IVT + LDWKVT*M
+               IF( LWORK.GE.M*N+M*M+3*M ) THEN
+*
+*                 WORK(IL) M by N
+*
+                  LDWRKL = M
+                  CHUNK = N
+               ELSE
+*
+*                 WORK(IL) is M by CHUNK
+*
+                  LDWRKL = M
+                  CHUNK = ( LWORK-M*M-3*M ) / M
+               END IF
+               ITAU = IL + LDWRKL*CHUNK
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing about above it
+*
+               CALL CLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              Generate Q in A
+*              (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IL)
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL CGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + M
+               IRVT = IRU + M*M
+               NRWORK = IRVT + M*M
+               CALL SBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by the left singular vectors of L
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
+*              Overwrite WORK(IVT) by the right singular vectors of L
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
+     $                      LDWKVT )
+               CALL CUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IL) by Q
+*              in A, storing result in WORK(IL) and copying to A
+*              (CWorkspace: need 2*M*M, prefer M*M+M*N))
+*              (RWorkspace: 0)
+*
+               DO 40 I = 1, N, CHUNK
+                  BLK = MIN( N-I+1, CHUNK )
+                  CALL CGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IVT ), M,
+     $                        A( 1, I ), LDA, CZERO, WORK( IL ),
+     $                        LDWRKL )
+                  CALL CLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
+     $                         A( 1, I ), LDA )
+   40          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*             Path 3t (N much larger than M, JOBZ='S')
+*             M right singular vectors to be computed in VT and
+*             M left singular vectors to be computed in U
+*
+               IL = 1
+*
+*              WORK(IL) is M by M
+*
+               LDWRKL = M
+               ITAU = IL + LDWRKL*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing out above it
+*
+               CALL CLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              Generate Q in A
+*              (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IL)
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL CGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + M
+               IRVT = IRU + M*M
+               NRWORK = IRVT + M*M
+               CALL SBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of L
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by left singular vectors of L
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy VT to WORK(IL), multiply right singular vectors of L
+*              in WORK(IL) by Q in A, storing result in VT
+*              (CWorkspace: need M*M)
+*              (RWorkspace: 0)
+*
+               CALL CLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
+               CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IL ), LDWRKL,
+     $                     A, LDA, CZERO, VT, LDVT )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 9t (N much larger than M, JOBZ='A')
+*              N right singular vectors to be computed in VT and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+*
+*              WORK(IVT) is M by M
+*
+               LDWKVT = M
+               ITAU = IVT + LDWKVT*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q, copying result to VT
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*              Generate Q in VT
+*              (CWorkspace: need M+N, prefer M+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce L in A, zeroing out above it
+*
+               CALL CLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL CGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + M
+               IRVT = IRU + M*M
+               NRWORK = IRVT + M*M
+               CALL SBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of L
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
+*              Overwrite WORK(IVT) by right singular vectors of L
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
+     $                      LDWKVT )
+               CALL CUNMBR( 'P', 'R', 'C', M, M, M, A, LDA,
+     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IVT) by
+*              Q in VT, storing result in A
+*              (CWorkspace: need M*M)
+*              (RWorkspace: 0)
+*
+               CALL CGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ),
+     $                     LDWKVT, VT, LDVT, CZERO, A, LDA )
+*
+*              Copy right singular vectors of A from A to VT
+*
+               CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+            END IF
+*
+         ELSE IF( N.GE.MNTHR2 ) THEN
+*
+*           MNTHR2 <= N < MNTHR1
+*
+*           Path 5t (N much larger than M, but not as much as MNTHR1)
+*           Reduce to bidiagonal form without QR decomposition, use
+*           CUNGBR and matrix multiplication to compute singular vectors
+*
+*
+            IE = 1
+            NRWORK = IE + M
+            ITAUQ = 1
+            ITAUP = ITAUQ + M
+            NWORK = ITAUP + M
+*
+*           Bidiagonalize A
+*           (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
+*           (RWorkspace: M)
+*
+            CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+*
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               IVT = NWORK
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Generate P**H in A
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+               LDWKVT = M
+               IF( LWORK.GE.M*N+3*M ) THEN
+*
+*                 WORK( IVT ) is M by N
+*
+                  NWORK = IVT + LDWKVT*N
+                  CHUNK = N
+               ELSE
+*
+*                 WORK( IVT ) is M by CHUNK
+*
+                  CHUNK = ( LWORK-3*M ) / M
+                  NWORK = IVT + LDWKVT*CHUNK
+               END IF
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply Q in U by real matrix RWORK(IRVT)
+*              storing the result in WORK(IVT), copying to U
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 2*M*M)
+*
+               CALL CLACRM( M, M, U, LDU, RWORK( IRU ), M, WORK( IVT ),
+     $                      LDWKVT, RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, M, WORK( IVT ), LDWKVT, U, LDU )
+*
+*              Multiply RWORK(IRVT) by P**H in A, storing the
+*              result in WORK(IVT), copying to A
+*              (CWorkspace: need M*M, prefer M*N)
+*              (Rworkspace: need 2*M*M, prefer 2*M*N)
+*
+               NRWORK = IRU
+               DO 50 I = 1, N, CHUNK
+                  BLK = MIN( N-I+1, CHUNK )
+                  CALL CLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ), LDA,
+     $                         WORK( IVT ), LDWKVT, RWORK( NRWORK ) )
+                  CALL CLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
+     $                         A( 1, I ), LDA )
+   50          CONTINUE
+            ELSE IF( WNTQS ) THEN
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               CALL CUNGBR( 'P', M, N, M, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: need 0)
+*              (Rworkspace: need 3*M*M)
+*
+               CALL CLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need M*M+2*M*N)
+*
+               NRWORK = IRU
+               CALL CLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT )
+            ELSE
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL CUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               CALL CUNGBR( 'P', N, N, M, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: need 0)
+*              (Rworkspace: need 3*M*M)
+*
+               CALL CLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need M*M+2*M*N)
+*
+               CALL CLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL CLACPY( 'F', M, N, A, LDA, VT, LDVT )
+            END IF
+*
+         ELSE
+*
+*           N .LT. MNTHR2
+*
+*           Path 6t (N greater than M, but not much larger)
+*           Reduce to bidiagonal form without LQ decomposition
+*           Use CUNMBR to compute singular vectors
+*
+            IE = 1
+            NRWORK = IE + M
+            ITAUQ = 1
+            ITAUP = ITAUQ + M
+            NWORK = ITAUP + M
+*
+*           Bidiagonalize A
+*           (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
+*           (RWorkspace: M)
+*
+            CALL CGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL SBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               LDWKVT = M
+               IVT = NWORK
+               IF( LWORK.GE.M*N+3*M ) THEN
+*
+*                 WORK( IVT ) is M by N
+*
+                  CALL CLASET( 'F', M, N, CZERO, CZERO, WORK( IVT ),
+     $                         LDWKVT )
+                  NWORK = IVT + LDWKVT*N
+               ELSE
+*
+*                 WORK( IVT ) is M by CHUNK
+*
+                  CHUNK = ( LWORK-3*M ) / M
+                  NWORK = IVT + LDWKVT*CHUNK
+               END IF
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: need 0)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*M ) THEN
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
+*              Overwrite WORK(IVT) by right singular vectors of A,
+*              copying to A
+*              (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB)
+*              (Rworkspace: need 0)
+*
+                  CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
+     $                         LDWKVT )
+                  CALL CUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
+     $                         WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+                  CALL CLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
+               ELSE
+*
+*                 Generate P**H in A
+*                 (Cworkspace: need 2*M, prefer M+M*NB)
+*                 (Rworkspace: need 0)
+*
+                  CALL CUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by real matrix RWORK(IRU), storing the
+*                 result in WORK(IU), copying to A
+*                 (CWorkspace: need M*M, prefer M*N)
+*                 (Rworkspace: need 3*M*M, prefer M*M+2*M*N)
+*
+                  NRWORK = IRU
+                  DO 60 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL CLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ),
+     $                            LDA, WORK( IVT ), LDWKVT,
+     $                            RWORK( NRWORK ) )
+                     CALL CLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
+     $                            A( 1, I ), LDA )
+   60             CONTINUE
+               END IF
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: M*M)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: M*M)
+*
+               CALL CLASET( 'F', M, N, CZERO, CZERO, VT, LDVT )
+               CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+*
+               CALL SBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: M*M)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL CUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Set all of VT to identity matrix
+*
+               CALL CLASET( 'F', N, N, CZERO, CONE, VT, LDVT )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*              (RWorkspace: M*M)
+*
+               CALL CLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
+               CALL CUNMBR( 'P', 'R', 'C', N, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ISCL.EQ.1 ) THEN
+         IF( ANRM.GT.BIGNUM )
+     $      CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+     $      CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
+     $                   RWORK( IE ), MINMN, IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+     $      CALL SLASCL( '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 CGESDD
+*
+      END
diff --git a/SRC/cgesv.f b/SRC/cgesv.f
new file mode 100644
index 00000000..7b362dd3
--- /dev/null
+++ b/SRC/cgesv.f
@@ -0,0 +1,107 @@
+      SUBROUTINE CGESV( 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( * )
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGESV computes the solution to a complex 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) COMPLEX 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) COMPLEX 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           CGETRF, CGETRS, 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( 'CGESV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of A.
+*
+      CALL CGETRF( N, N, A, LDA, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
+     $                INFO )
+      END IF
+      RETURN
+*
+*     End of CGESV
+*
+      END
diff --git a/SRC/cgesvd.f b/SRC/cgesvd.f
new file mode 100644
index 00000000..9ba709f9
--- /dev/null
+++ b/SRC/cgesvd.f
@@ -0,0 +1,3602 @@
+      SUBROUTINE CGESVD( 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 ..
+      REAL               RWORK( * ), S( * )
+      COMPLEX            A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGESVD 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 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) REAL array, dimension (min(M,N))
+*          The singular values of A, sorted so that S(i) >= S(i+1).
+*
+*  U       (output) COMPLEX 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 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 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) REAL 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 CBDSQR 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            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. 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
+      REAL               ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 )
+      COMPLEX            CDUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CBDSQR, CGEBRD, CGELQF, CGEMM, CGEQRF, CLACPY,
+     $                   CLASCL, CLASET, CUNGBR, CUNGLQ, CUNGQR, CUNMBR,
+     $                   SLASCL, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. 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 CBDSQR is BDSPAC = 5*N
+*
+            MNTHR = ILAENV( 6, 'CGESVD', 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, 'CGEQRF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 2*N+2*N*
+     $                     ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  IF( WNTVO .OR. WNTVAS )
+     $               MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
+     $                        ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'CUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'CGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'CUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTUS .OR. WNTUO )
+     $            MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, N, N, -1 ) )
+               IF( WNTUA )
+     $            MAXWRK = MAX( MAXWRK, 2*N+M*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, M, N, -1 ) )
+               IF( .NOT.WNTVN )
+     $            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
+     $                     ILAENV( 1, 'CUNGBR', 'P', N, N, N, -1 ) )
+               MINWRK = 2*N + M
+            END IF
+         ELSE IF( MINMN.GT.0 ) THEN
+*
+*           Space needed for CBDSQR is BDSPAC = 5*M
+*
+            MNTHR = ILAENV( 6, 'CGESVD', 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, 'CGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M+2*M*
+     $                     ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  IF( WNTUO .OR. WNTUAS )
+     $               MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                        ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'CUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'CUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'CUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'CUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'CGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'CUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'CUNGBR', '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, 'CGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTVS .OR. WNTVO )
+     $            MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'CUNGBR', 'P', M, N, M, -1 ) )
+               IF( WNTVA )
+     $            MAXWRK = MAX( MAXWRK, 2*M+N*
+     $                     ILAENV( 1, 'CUNGBR', 'P', N, N, M, -1 ) )
+               IF( .NOT.WNTUN )
+     $            MAXWRK = MAX( MAXWRK, 2*M+( M-1 )*
+     $                     ILAENV( 1, 'CUNGBR', 'Q', M, M, M, -1 ) )
+               MINWRK = 2*M + N
+            END IF
+         END IF
+         MAXWRK = MAX( MINWRK, MAXWRK )
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGESVD', -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 = SLAMCH( 'P' )
+      SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL CLASCL( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL CLASET( '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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CLACPY( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to WORK(IR) and zero out below it
+*
+                  CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+                  CALL CLASET( '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 CUNGQR( 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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL CLACPY( '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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL CLASET( '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 CUNGQR( 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 CGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL CLACPY( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL CLASET( '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 CUNGQR( 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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL CLASET( '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 CUNGQR( 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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGQR( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CUNGQR( 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 CGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGQR( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CUNGQR( 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 CGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to VT, zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL CLASET( '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 CUNGQR( 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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N+M, prefer N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGQR( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+*                    Copy right singular vectors of R from WORK(IR) to A
+*
+                     CALL CLACPY( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N+M, prefer N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGQR( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( '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 CGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N+M, prefer N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R from A to VT, zeroing out below it
+*
+                     CALL CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGEBRD( 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 CLACPY( 'L', M, N, A, LDA, U, LDU )
+               IF( WNTUS )
+     $            NCU = N
+               IF( WNTUA )
+     $            NCU = M
+               CALL CUNGBR( '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 CLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL CUNGBR( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CBDSQR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL CLASET( '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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CLACPY( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to WORK(IR) and zero out above it
+*
+                  CALL CLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+                  CALL CLASET( '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 CUNGLQ( 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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL CLACPY( '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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing about above it
+*
+                  CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL CLASET( '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 CUNGLQ( 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 CGEBRD( M, M, U, LDU, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL CLACPY( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing out above it
+*
+                  CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL CLASET( '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 CUNGLQ( 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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL CLASET( '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 CUNGLQ( 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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy result to VT
+*
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGLQ( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out below it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CUNGLQ( 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 CGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGLQ( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CUNGLQ( 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 CGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL CLASET( '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 CUNGLQ( 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 CGEBRD( 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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M+N, prefer M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGLQ( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy left singular vectors of A from WORK(IR) to A
+*
+                     CALL CLACPY( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M+N, prefer M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGLQ( 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 CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL CLASET( '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 CGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL CLACPY( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CGEMM( '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 CLACPY( '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 CGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M+N, prefer M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL CUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL CLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL CLASET( '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 CGEBRD( 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 CUNMBR( '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 CUNGBR( '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 CBDSQR( '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 CGEBRD( 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 CLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL CUNGBR( '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 CLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               IF( WNTVA )
+     $            NRVT = N
+               IF( WNTVS )
+     $            NRVT = M
+               CALL CUNGBR( '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 CUNGBR( '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 CUNGBR( '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 CBDSQR( '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 CBDSQR( '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 CBDSQR( '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 SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+     $      CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
+     $                   RWORK( IE ), MINMN, IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+     $      CALL SLASCL( '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 CGESVD
+*
+      END
diff --git a/SRC/cgesvx.f b/SRC/cgesvx.f
new file mode 100644
index 00000000..0f435079
--- /dev/null
+++ b/SRC/cgesvx.f
@@ -0,0 +1,481 @@
+      SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
+     $                   EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, RWORK, 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGESVX uses the LU factorization to compute the solution to a complex
+*  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  (Conjugate 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) COMPLEX 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) COMPLEX 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 CGETRF.  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 CGETRF; 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) REAL 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) REAL 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) COMPLEX 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) COMPLEX 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) REAL
+*          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) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace/output) REAL array, dimension (2*N)
+*          On exit, RWORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If RWORK(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
+*          RWORK(1) contains the reciprocal pivot growth factor for the
+*          leading INFO columns of A.
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+      CHARACTER          NORM
+      INTEGER            I, INFEQU, J
+      REAL               AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANGE, CLANTR, SLAMCH
+      EXTERNAL           LSAME, CLANGE, CLANTR, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGECON, CGEEQU, CGERFS, CGETRF, CGETRS, CLACPY,
+     $                   CLAQGE, 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 = SLAMCH( '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( 'CGESVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL CGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL CLAQGE( 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 CLACPY( 'Full', N, N, A, LDA, AF, LDAF )
+         CALL CGETRF( 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 = CLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
+     $               RWORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = CLANGE( 'M', N, INFO, A, LDA, RWORK ) /
+     $                  RPVGRW
+            END IF
+            RWORK( 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 = CLANGE( NORM, N, N, A, LDA, RWORK )
+      RPVGRW = CLANTR( 'M', 'U', 'N', N, N, AF, LDAF, RWORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = CLANGE( 'M', N, N, A, LDA, RWORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CGETRS( 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 CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, 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
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RWORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of CGESVX
+*
+      END
diff --git a/SRC/cgetc2.f b/SRC/cgetc2.f
new file mode 100644
index 00000000..ac7608f5
--- /dev/null
+++ b/SRC/cgetc2.f
@@ -0,0 +1,145 @@
+      SUBROUTINE CGETC2( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETC2 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 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IP, IPV, J, JP, JPV
+      REAL               BIGNUM, EPS, SMIN, SMLNUM, XMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGERU, CSWAP, SLABAD
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CMPLX, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Set constants to control overflow
+*
+      INFO = 0
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( 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 CSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
+         IPIV( I ) = IPV
+*
+*        Swap columns
+*
+         IF( JPV.NE.I )
+     $      CALL CSWAP( 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 ) = CMPLX( SMIN, ZERO )
+         END IF
+         DO 30 J = I + 1, N
+            A( J, I ) = A( J, I ) / A( I, I )
+   30    CONTINUE
+         CALL CGERU( N-I, N-I, -CMPLX( 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 ) = CMPLX( SMIN, ZERO )
+      END IF
+      RETURN
+*
+*     End of CGETC2
+*
+      END
diff --git a/SRC/cgetf2.f b/SRC/cgetf2.f
new file mode 100644
index 00000000..48b0d794
--- /dev/null
+++ b/SRC/cgetf2.f
@@ -0,0 +1,148 @@
+      SUBROUTINE CGETF2( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETF2 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 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            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      REAL               SFMIN
+      INTEGER            I, J, JP
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      INTEGER            ICAMAX
+      EXTERNAL           SLAMCH, ICAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGERU, CSCAL, CSWAP, 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( 'CGETF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Compute machine safe minimum
+*
+      SFMIN = SLAMCH('S') 
+*
+      DO 10 J = 1, MIN( M, N )
+*
+*        Find pivot and test for singularity.
+*
+         JP = J - 1 + ICAMAX( 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 CSWAP( 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 CSCAL( 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 CGERU( 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 CGETF2
+*
+      END
diff --git a/SRC/cgetrf.f b/SRC/cgetrf.f
new file mode 100644
index 00000000..9c6fd5ad
--- /dev/null
+++ b/SRC/cgetrf.f
@@ -0,0 +1,159 @@
+      SUBROUTINE CGETRF( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETRF 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CGETF2, CLASWP, CTRSM, 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( 'CGETRF', -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, 'CGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL CGETF2( 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 CGETF2( 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 CLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply interchanges to columns J+JB:N.
+*
+               CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
+     $                      IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL CTRSM( '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 CGEMM( '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 CGETRF
+*
+      END
diff --git a/SRC/cgetri.f b/SRC/cgetri.f
new file mode 100644
index 00000000..86b3ad32
--- /dev/null
+++ b/SRC/cgetri.f
@@ -0,0 +1,193 @@
+      SUBROUTINE CGETRI( 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            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETRI computes the inverse of a matrix using the LU factorization
+*  computed by CGETRF.
+*
+*  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 array, dimension (LDA,N)
+*          On entry, the factors L and U from the factorization
+*          A = P*L*U as computed by CGETRF.
+*          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 CGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+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           CGEMM, CGEMV, CSWAP, CTRSM, CTRTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NB = ILAENV( 1, 'CGETRI', ' ', 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( 'CGETRI', -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 CTRTRI, then U is singular,
+*     and the inverse is not computed.
+*
+      CALL CTRTRI( '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, 'CGETRI', ' ', 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 CGEMV( '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 CGEMM( '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 CTRSM( '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 CSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
+   60 CONTINUE
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of CGETRI
+*
+      END
diff --git a/SRC/cgetrs.f b/SRC/cgetrs.f
new file mode 100644
index 00000000..0b58ad7a
--- /dev/null
+++ b/SRC/cgetrs.f
@@ -0,0 +1,149 @@
+      SUBROUTINE CGETRS( 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            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGETRS 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 CGETRF.
+*
+*  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 array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by CGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from CGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASWP, CTRSM, 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( 'CGETRS', -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 CLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
+*
+*        Solve L*X = B, overwriting B with X.
+*
+         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL CTRSM( '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 CTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
+     $               A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL CTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,
+     $               LDA, B, LDB )
+*
+*        Apply row interchanges to the solution vectors.
+*
+         CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
+      END IF
+*
+      RETURN
+*
+*     End of CGETRS
+*
+      END
diff --git a/SRC/cggbak.f b/SRC/cggbak.f
new file mode 100644
index 00000000..c0f6a8bf
--- /dev/null
+++ b/SRC/cggbak.f
@@ -0,0 +1,220 @@
+      SUBROUTINE CGGBAK( 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 ..
+      REAL               LSCALE( * ), RSCALE( * )
+      COMPLEX            V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGBAK 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
+*  CGGBAL.
+*
+*  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 CGGBAL.
+*
+*  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 CGGBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  LSCALE  (input) REAL array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the left side of A and B, as returned by CGGBAL.
+*
+*  RSCALE  (input) REAL array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the right side of A and B, as returned by CGGBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) COMPLEX array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by CTGEVC.
+*          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           CSSCAL, CSWAP, 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( 'CGGBAK', -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 CSSCAL( 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 CSSCAL( 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 CSWAP( 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 CSWAP( 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 CSWAP( 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 CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+  100       CONTINUE
+         END IF
+      END IF
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of CGGBAK
+*
+      END
diff --git a/SRC/cggbal.f b/SRC/cggbal.f
new file mode 100644
index 00000000..42007d3e
--- /dev/null
+++ b/SRC/cggbal.f
@@ -0,0 +1,482 @@
+      SUBROUTINE CGGBAL( 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 ..
+      REAL               LSCALE( * ), RSCALE( * ), WORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGBAL 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 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 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) REAL 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) REAL 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 ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+      REAL               THREE, SCLFAC
+      PARAMETER          ( THREE = 3.0E+0, SCLFAC = 1.0E+1 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+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
+      REAL               ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
+     $                   COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
+     $                   SFMIN, SUM, T, TA, TB, TC
+      COMPLEX            CDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SDOT, SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSSCAL, CSWAP, SAXPY, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, INT, LOG10, MAX, MIN, REAL, SIGN
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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( 'CGGBAL', -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.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 CSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
+      CALL CSWAP( 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 CSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL CSWAP( 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 / REAL( 2*NR )
+      COEF2 = COEF*COEF
+      COEF5 = HALF*COEF2
+      NRP2 = NR + 2
+      BETA = ZERO
+      IT = 1
+*
+*     Start generalized conjugate gradient iteration
+*
+  250 CONTINUE
+*
+      GAMMA = SDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
+     $        SDOT( 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 SSCAL( NR, BETA, WORK( ILO ), 1 )
+      CALL SSCAL( NR, BETA, WORK( ILO+N ), 1 )
+*
+      CALL SAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
+      CALL SAXPY( 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 ) = REAL( 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 ) = REAL( KOUNT )*WORK( J ) + SUM
+  330 CONTINUE
+*
+      SUM = SDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
+     $      SDOT( 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 SAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
+      CALL SAXPY( 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 = SLAMCH( 'S' )
+      SFMAX = ONE / SFMIN
+      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
+      LSFMAX = INT( LOG10( SFMAX ) / BASL )
+      DO 360 I = ILO, IHI
+         IRAB = ICAMAX( N-ILO+1, A( I, ILO ), LDA )
+         RAB = ABS( A( I, IRAB+ILO-1 ) )
+         IRAB = ICAMAX( 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 = ICAMAX( IHI, A( 1, I ), 1 )
+         CAB = ABS( A( ICAB, I ) )
+         ICAB = ICAMAX( 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 CSSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
+         CALL CSSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
+  370 CONTINUE
+*
+*     Column scaling of matrices A and B
+*
+      DO 380 J = ILO, IHI
+         CALL CSSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
+         CALL CSSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
+  380 CONTINUE
+*
+      RETURN
+*
+*     End of CGGBAL
+*
+      END
diff --git a/SRC/cgges.f b/SRC/cgges.f
new file mode 100644
index 00000000..b6898b83
--- /dev/null
+++ b/SRC/cgges.f
@@ -0,0 +1,477 @@
+      SUBROUTINE CGGES( 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( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGES 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
+*  CGGEV 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 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 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 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 array, dimension (N)
+*  BETA    (output) COMPLEX 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 CGGES. 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 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 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 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) REAL 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 CHGEQZ
+*                =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 CTGSEN.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. 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
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
+     $                   PVSR, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      REAL               DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
+     $                   CLASCL, CLASET, CTGSEN, CUNGQR, CUNMQR, SLABAD,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. 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, 'CGEQRF', ' ', N, 1, N, 0 ) )
+         LWKOPT = MAX( LWKOPT, N +
+     $                 N*ILAENV( 1, 'CUNMQR', ' ', N, 1, N, -1 ) )
+         IF( ILVSL ) THEN
+            LWKOPT = MAX( LWKOPT, N +
+     $                    N*ILAENV( 1, 'CUNGQR', ' ', 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( 'CGGES ', -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 = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = CLANGE( '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 CLASCL( '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 CGGBAL( '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 CGEQRF( 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 CUNMQR( '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 CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL CUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL CGGHRD( 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 CHGEQZ( '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 CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR )
+         IF( ILBSCL )
+     $      CALL CLASCL( '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 CTGSEN( 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 CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSL, LDVSL, IERR )
+      IF( ILVSR )
+     $   CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL CLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL CLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL CLASCL( '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 CGGES
+*
+      END
diff --git a/SRC/cggesx.f b/SRC/cggesx.f
new file mode 100644
index 00000000..d951695c
--- /dev/null
+++ b/SRC/cggesx.f
@@ -0,0 +1,578 @@
+      SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
+     $                   B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR,
+     $                   LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK,
+     $                   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          JOBVSL, JOBVSR, SENSE, SORT
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
+     $                   SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      REAL               RCONDE( 2 ), RCONDV( 2 ), RWORK( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGESX computes for a pair of N-by-N complex nonsymmetric matrices
+*  (A,B), the generalized eigenvalues, the complex Schur form (S,T),
+*  and, optionally, the left and/or right matrices of Schur vectors (VSL
+*  and VSR).  This gives the generalized Schur factorization
+*
+*       (A,B) = ( (VSL) S (VSR)**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; computes
+*  a reciprocal condition number for the average of the selected
+*  eigenvalues (RCONDE); and computes a reciprocal condition number for
+*  the right and left deflating subspaces corresponding to the selected
+*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form
+*  an orthonormal basis for the corresponding left and right eigenspaces
+*  (deflating subspaces).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
+*  usually represented as the pair (alpha,beta), as there is a
+*  reasonable interpretation for beta=0 or for both being zero.
+*
+*  A pair of matrices (S,T) is in generalized complex Schur form if T is
+*  upper triangular with non-negative diagonal and S is upper
+*  triangular.
+*
+*  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 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.
+*          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+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 deflating subspaces only;
+*          = 'B' : Computed for both.
+*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VSL, and VSR.  N >= 0.
+*
+*  A       (input/output) COMPLEX 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 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 array, dimension (N)
+*  BETA    (output) COMPLEX array, dimension (N)
+*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
+*          generalized eigenvalues.  ALPHA(j) and BETA(j),j=1,...,N  are
+*          the diagonals of the complex Schur form (S,T).  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 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 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.
+*
+*  RCONDE  (output) REAL array, dimension ( 2 )
+*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
+*          reciprocal condition numbers for the average of the selected
+*          eigenvalues.
+*          Not referenced if SENSE = 'N' or 'V'.
+*
+*  RCONDV  (output) REAL array, dimension ( 2 )
+*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
+*          reciprocal condition number for the selected deflating
+*          subspaces.
+*          Not referenced if SENSE = 'N' or 'E'.
+*
+*  WORK    (workspace/output) COMPLEX 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 N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
+*          LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else
+*          LWORK >= MAX(1,2*N).  Note that 2*SDIM*(N-SDIM) <= N*N/2.
+*          Note also that an error is only returned if
+*          LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may
+*          not be large enough.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the bound on the optimal size of the WORK
+*          array and the minimum size of the IWORK array, returns these
+*          values as the first entries of the WORK and IWORK arrays, and
+*          no error message related to LWORK or LIWORK is issued by
+*          XERBLA.
+*
+*  RWORK   (workspace) REAL array, dimension ( 8*N )
+*          Real workspace.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array WORK.
+*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
+*          LIWORK >= N+2.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the bound on the optimal size of the
+*          WORK array and the minimum size of the IWORK array, returns
+*          these values as the first entries of the WORK and IWORK
+*          arrays, and no error message related to LWORK or LIWORK is
+*          issued by XERBLA.
+*
+*  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 CHGEQZ
+*                =N+2: after reordering, roundoff changed values of
+*                      some complex eigenvalues so that leading
+*                      eigenvalues in the Generalized Schur form no
+*                      longer satisfy SELCTG=.TRUE.  This could also
+*                      be caused due to scaling.
+*                =N+3: reordering failed in CTGSEN.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+     $                   LQUERY, WANTSB, WANTSE, WANTSN, WANTST, WANTSV
+      INTEGER            I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
+     $                   ILEFT, ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK,
+     $                   LIWMIN, LWRK, MAXWRK, MINWRK
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
+     $                   PR, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
+     $                   CLASCL, CLASET, CTGSEN, CUNGQR, CUNMQR, SLABAD,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. 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' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+      IF( WANTSN ) THEN
+         IJOB = 0
+      ELSE IF( WANTSE ) THEN
+         IJOB = 1
+      ELSE IF( WANTSV ) THEN
+         IJOB = 2
+      ELSE IF( WANTSB ) THEN
+         IJOB = 4
+      END IF
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+     $         ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -15
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -17
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.GT.0) THEN
+            MINWRK = 2*N
+            MAXWRK = N*(1 + ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) )
+            MAXWRK = MAX( MAXWRK, N*( 1 +
+     $                    ILAENV( 1, 'CUNMQR', ' ', N, 1, N, -1 ) ) )
+            IF( ILVSL ) THEN
+               MAXWRK = MAX( MAXWRK, N*( 1 +
+     $                       ILAENV( 1, 'CUNGQR', ' ', N, 1, N, -1 ) ) )
+            END IF
+            LWRK = MAXWRK
+            IF( IJOB.GE.1 )
+     $         LWRK = MAX( LWRK, N*N/2 )
+         ELSE
+            MINWRK = 1
+            MAXWRK = 1
+            LWRK   = 1
+         END IF
+         WORK( 1 ) = LWRK
+         IF( WANTSN .OR. N.EQ.0 ) THEN
+            LIWMIN = 1
+         ELSE
+            LIWMIN = N + 2
+         END IF
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -21
+         ELSE IF( LIWORK.LT.LIWMIN  .AND. .NOT.LQUERY) THEN
+            INFO = -24
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGESX', -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 = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = CLANGE( '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 CLASCL( '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 CGGBAL( '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 CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the unitary transformation to matrix A
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      CALL CUNMQR( '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 CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL CUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL CGGHRD( 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 CHGEQZ( '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 40
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA and compute the reciprocal of
+*     condition number(s)
+*
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before SELCTGing
+*
+         IF( ILASCL )
+     $      CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+         IF( ILBSCL )
+     $      CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues, transform Generalized Schur vectors, and
+*        compute reciprocal condition numbers
+*        (Complex Workspace: If IJOB >= 1, need MAX(1, 2*SDIM*(N-SDIM))
+*                            otherwise, need 1 )
+*
+         CALL CTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
+     $                ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PL, PR,
+     $                DIF, WORK( IWRK ), LWORK-IWRK+1, IWORK, LIWORK,
+     $                IERR )
+*
+         IF( IJOB.GE.1 )
+     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+         IF( IERR.EQ.-21 ) THEN
+*
+*            not enough complex workspace
+*
+            INFO = -21
+         ELSE
+            IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
+               RCONDE( 1 ) = PL
+               RCONDE( 2 ) = PR
+            END IF
+            IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+               RCONDV( 1 ) = DIF( 1 )
+               RCONDV( 2 ) = DIF( 2 )
+            END IF
+            IF( IERR.EQ.1 )
+     $         INFO = N + 3
+         END IF
+*
+      END IF
+*
+*     Apply permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+      IF( ILVSR )
+     $   CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL CLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL CLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL CLASCL( '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 30 I = 1, N
+            CURSL = SELCTG( ALPHA( I ), BETA( I ) )
+            IF( CURSL )
+     $         SDIM = SDIM + 1
+            IF( CURSL .AND. .NOT.LASTSL )
+     $         INFO = N + 2
+            LASTSL = CURSL
+   30    CONTINUE
+*
+      END IF
+*
+   40 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of CGGESX
+*
+      END
diff --git a/SRC/cggev.f b/SRC/cggev.f
new file mode 100644
index 00000000..e6403e85
--- /dev/null
+++ b/SRC/cggev.f
@@ -0,0 +1,454 @@
+      SUBROUTINE CGGEV( 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 ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGEV 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 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 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 array, dimension (N)
+*  BETA    (output) COMPLEX 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 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 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 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) REAL 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 SHGEQZ,
+*                =N+2: error return from STGEVC.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. 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
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+      COMPLEX            X
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
+     $                   CLASCL, CLASET, CTGEVC, CUNGQR, CUNMQR, SLABAD,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( 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, 'CGEQRF', ' ', N, 1, N, 0 ) )
+         LWKOPT = MAX( LWKOPT, N +
+     $                 N*ILAENV( 1, 'CUNMQR', ' ', N, 1, N, 0 ) ) 
+         IF( ILVL ) THEN
+            LWKOPT = MAX( LWKOPT, N +
+     $                 N*ILAENV( 1, 'CUNGQR', ' ', 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( 'CGGEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = CLANGE( '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 CLASCL( '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 CGGBAL( '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 CGEQRF( 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 CUNMQR( '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 CLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL CUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VR
+*
+      IF( ILVR )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      IF( ILV ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL CGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL CGGHRD( '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 CHGEQZ( 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 CTGEVC( 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 CGGBAK( '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 CGGBAK( '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 CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+*
+      IF( ILBSCL )
+     $   CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+   70 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CGGEV
+*
+      END
diff --git a/SRC/cggevx.f b/SRC/cggevx.f
new file mode 100644
index 00000000..63d9ebbd
--- /dev/null
+++ b/SRC/cggevx.f
@@ -0,0 +1,652 @@
+      SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
+     $                   ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI,
+     $                   LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV,
+     $                   WORK, LWORK, RWORK, IWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+      REAL               ABNRM, BBNRM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      REAL               LSCALE( * ), RCONDE( * ), RCONDV( * ),
+     $                   RSCALE( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGEVX 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.
+*
+*  Optionally, it also computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
+*  the eigenvalues (RCONDE), and reciprocal condition numbers for the
+*  right eigenvectors (RCONDV).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+*  singular. It is usually represented as the pair (alpha,beta), as
+*  there is a reasonable interpretation for beta=0, and even for both
+*  being zero.
+*
+*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*                   A * v(j) = lambda(j) * B * v(j) .
+*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*                   u(j)**H * A  = lambda(j) * u(j)**H * B.
+*  where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Specifies the balance option to be performed:
+*          = 'N':  do not diagonally scale or permute;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*          Computed reciprocal condition numbers will be for the
+*          matrices after permuting and/or balancing. Permuting does
+*          not change condition numbers (in exact arithmetic), but
+*          balancing does.
+*
+*  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.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': none are computed;
+*          = 'E': computed for eigenvalues only;
+*          = 'V': computed for eigenvectors only;
+*          = 'B': computed for eigenvalues and eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VL, and VR.  N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA, N)
+*          On entry, the matrix A in the pair (A,B).
+*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
+*          or both, then A contains the first part of the complex Schur
+*          form of the "balanced" versions of the input A and B.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB, N)
+*          On entry, the matrix B in the pair (A,B).
+*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
+*          or both, then B contains the second part of the complex
+*          Schur form of the "balanced" versions of the input A and B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX array, dimension (N)
+*  BETA    (output) COMPLEX array, dimension (N)
+*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized
+*          eigenvalues.
+*
+*          Note: the quotient 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 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 will be scaled so the largest component
+*          will have 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 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 will be scaled so the largest component
+*          will have 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.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values such that on exit
+*          A(i,j) = 0 and B(i,j) = 0 if i > j and
+*          j = 1,...,ILO-1 or i = IHI+1,...,N.
+*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  LSCALE  (output) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the left side of A and B.  If PL(j) is the index of the
+*          row interchanged with row j, and DL(j) is the scaling
+*          factor applied to row j, then
+*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1
+*                      = DL(j)  for j = ILO,...,IHI
+*                      = PL(j)  for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  RSCALE  (output) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the right side of A and B.  If PR(j) is the index of the
+*          column interchanged with column j, and DR(j) is the scaling
+*          factor applied to column j, then
+*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1
+*                      = DR(j)  for j = ILO,...,IHI
+*                      = PR(j)  for j = IHI+1,...,N
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) REAL
+*          The one-norm of the balanced matrix A.
+*
+*  BBNRM   (output) REAL
+*          The one-norm of the balanced matrix B.
+*
+*  RCONDE  (output) REAL array, dimension (N)
+*          If SENSE = 'E' or 'B', the reciprocal condition numbers of
+*          the eigenvalues, stored in consecutive elements of the array.
+*          If SENSE = 'N' or 'V', RCONDE is not referenced.
+*
+*  RCONDV  (output) REAL array, dimension (N)
+*          If SENSE = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the eigenvectors, stored in consecutive elements
+*          of the array. If the eigenvalues cannot be reordered to
+*          compute RCONDV(j), RCONDV(j) is set to 0; this can only occur
+*          when the true value would be very small anyway. 
+*          If SENSE = 'N' or 'E', RCONDV is not referenced.
+*
+*  WORK    (workspace/output) COMPLEX 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).
+*          If SENSE = 'E', LWORK >= max(1,4*N).
+*          If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*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) REAL array, dimension (lrwork)
+*          lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',
+*          and at least max(1,2*N) otherwise.
+*          Real workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N+2)
+*          If SENSE = 'E', IWORK is not referenced.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          If SENSE = 'N', BWORK is not referenced.
+*
+*  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 than QZ iteration failed in CHGEQZ.
+*                =N+2: error return from CTGEVC.
+*
+*  Further Details
+*  ===============
+*
+*  Balancing a matrix pair (A,B) includes, first, permuting rows and
+*  columns to isolate eigenvalues, second, applying diagonal similarity
+*  transformation to the rows and columns to make the rows and columns
+*  as close in norm as possible. The computed reciprocal condition
+*  numbers correspond to the balanced matrix. Permuting rows and columns
+*  will not change the condition numbers (in exact arithmetic) but
+*  diagonal scaling will.  For further explanation of balancing, see
+*  section 4.11.1.2 of LAPACK Users' Guide.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
+*
+*  An approximate error bound for the angle between the i-th computed
+*  eigenvector VL(i) or VR(i) is given by
+*
+*       EPS * norm(ABNRM, BBNRM) / DIF(i).
+*
+*  For further explanation of the reciprocal condition numbers RCONDE
+*  and RCONDV, see section 4.11 of LAPACK User's Guide.
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
+     $                   WANTSB, WANTSE, WANTSN, WANTSV
+      CHARACTER          CHTEMP
+      INTEGER            I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
+     $                   ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, MINWRK
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+      COMPLEX            X
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
+     $                   CLASCL, CLASET, CTGEVC, CTGSNA, CUNGQR, CUNMQR,
+     $                   SLABAD, SLASCL, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( 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
+*
+      NOSCL  = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.( NOSCL .OR. LSAME( BALANC,'S' ) .OR.
+     $    LSAME( BALANC, 'B' ) ) ) THEN
+         INFO = -1
+      ELSE IF( IJOBVL.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
+     $          THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -15
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV. The workspace is
+*       computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MINWRK = 2*N
+            IF( WANTSE ) THEN
+               MINWRK = 4*N
+            ELSE IF( WANTSV .OR. WANTSB ) THEN
+               MINWRK = 2*N*( N + 1)
+            END IF
+            MAXWRK = MINWRK
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 ) )
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'CUNMQR', ' ', N, 1, N, 0 ) )
+            IF( ILVL ) THEN
+               MAXWRK = MAX( MAXWRK, N +
+     $                       N*ILAENV( 1, 'CUNGQR', ' ', N, 1, N, 0 ) )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -25
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = CLANGE( '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 CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = CLANGE( '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 CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute and/or balance the matrix pair (A,B)
+*     (Real Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
+*
+      CALL CGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+     $             RWORK, IERR )
+*
+*     Compute ABNRM and BBNRM
+*
+      ABNRM = CLANGE( '1', N, N, A, LDA, RWORK( 1 ) )
+      IF( ILASCL ) THEN
+         RWORK( 1 ) = ABNRM
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, RWORK( 1 ), 1,
+     $                IERR )
+         ABNRM = RWORK( 1 )
+      END IF
+*
+      BBNRM = CLANGE( '1', N, N, B, LDB, RWORK( 1 ) )
+      IF( ILBSCL ) THEN
+         RWORK( 1 ) = BBNRM
+         CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, RWORK( 1 ), 1,
+     $                IERR )
+         BBNRM = RWORK( 1 )
+      END IF
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Complex Workspace: need N, prefer N*NB )
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWRK = ITAU + IROWS
+      CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the unitary transformation to A
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VL and/or VR
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVL ) THEN
+         CALL CLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL CUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+      IF( ILVR )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL CGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL CGGHRD( '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)
+*     (Complex Workspace: need N)
+*     (Real Workspace: need N)
+*
+      IWRK = ITAU
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+*
+      CALL CHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ),
+     $             LWORK+1-IWRK, RWORK, 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 90
+      END IF
+*
+*     Compute Eigenvectors and estimate condition numbers if desired
+*     CTGEVC: (Complex Workspace: need 2*N )
+*             (Real Workspace:    need 2*N )
+*     CTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B')
+*             (Integer Workspace: need N+2 )
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         IF( ILV ) THEN
+            IF( ILVL ) THEN
+               IF( ILVR ) THEN
+                  CHTEMP = 'B'
+               ELSE
+                  CHTEMP = 'L'
+               END IF
+            ELSE
+               CHTEMP = 'R'
+            END IF
+*
+            CALL CTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, N, IN, WORK( IWRK ), RWORK,
+     $                   IERR )
+            IF( IERR.NE.0 ) THEN
+               INFO = N + 2
+               GO TO 90
+            END IF
+         END IF
+*
+         IF( .NOT.WANTSN ) THEN
+*
+*           compute eigenvectors (STGEVC) and estimate condition
+*           numbers (STGSNA). Note that the definition of the condition
+*           number is not invariant under transformation (u,v) to
+*           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
+*           Schur form (S,T), Q and Z are orthogonal matrices. In order
+*           to avoid using extra 2*N*N workspace, we have to
+*           re-calculate eigenvectors and estimate the condition numbers
+*           one at a time.
+*
+            DO 20 I = 1, N
+*
+               DO 10 J = 1, N
+                  BWORK( J ) = .FALSE.
+   10          CONTINUE
+               BWORK( I ) = .TRUE.
+*
+               IWRK = N + 1
+               IWRK1 = IWRK + N
+*
+               IF( WANTSE .OR. WANTSB ) THEN
+                  CALL CTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
+     $                         WORK( 1 ), N, WORK( IWRK ), N, 1, M,
+     $                         WORK( IWRK1 ), RWORK, IERR )
+                  IF( IERR.NE.0 ) THEN
+                     INFO = N + 2
+                     GO TO 90
+                  END IF
+               END IF
+*
+               CALL CTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
+     $                      WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
+     $                      RCONDV( I ), 1, M, WORK( IWRK1 ),
+     $                      LWORK-IWRK1+1, IWORK, IERR )
+*
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Undo balancing on VL and VR and normalization
+*     (Workspace: none needed)
+*
+      IF( ILVL ) THEN
+         CALL CGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
+     $                LDVL, IERR )
+*
+         DO 50 JC = 1, N
+            TEMP = ZERO
+            DO 30 JR = 1, N
+               TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
+   30       CONTINUE
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 50
+            TEMP = ONE / TEMP
+            DO 40 JR = 1, N
+               VL( JR, JC ) = VL( JR, JC )*TEMP
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      IF( ILVR ) THEN
+         CALL CGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
+     $                LDVR, IERR )
+         DO 80 JC = 1, N
+            TEMP = ZERO
+            DO 60 JR = 1, N
+               TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
+   60       CONTINUE
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 80
+            TEMP = ONE / TEMP
+            DO 70 JR = 1, N
+               VR( JR, JC ) = VR( JR, JC )*TEMP
+   70       CONTINUE
+   80    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ILASCL )
+     $   CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+*
+      IF( ILBSCL )
+     $   CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+   90 CONTINUE
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of CGGEVX
+*
+      END
diff --git a/SRC/cggglm.f b/SRC/cggglm.f
new file mode 100644
index 00000000..413b8778
--- /dev/null
+++ b/SRC/cggglm.f
@@ -0,0 +1,259 @@
+      SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, 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, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
+     $                   X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGGLM solves a general Gauss-Markov linear model (GLM) problem:
+*
+*          minimize || y ||_2   subject to   d = A*x + B*y
+*              x
+*
+*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
+*  given N-vector. It is assumed that M <= N <= M+P, and
+*
+*             rank(A) = M    and    rank( A B ) = N.
+*
+*  Under these assumptions, the constrained equation is always
+*  consistent, and there is a unique solution x and a minimal 2-norm
+*  solution y, which is obtained using a generalized QR factorization
+*  of the matrices (A, B) given by
+*
+*     A = Q*(R),   B = Q*T*Z.
+*           (0)
+*
+*  In particular, if matrix B is square nonsingular, then the problem
+*  GLM is equivalent to the following weighted linear least squares
+*  problem
+*
+*               minimize || inv(B)*(d-A*x) ||_2
+*                   x
+*
+*  where inv(B) denotes the inverse of B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B.  N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  0 <= M <= N.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= N-M.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the upper triangular part of the array A contains
+*          the M-by-M upper triangular matrix R.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  D       (input/output) COMPLEX array, dimension (N)
+*          On entry, D is the left hand side of the GLM equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) COMPLEX array, dimension (M)
+*  Y       (output) COMPLEX array, dimension (P)
+*          On exit, X and Y are the solutions of the GLM problem.
+*
+*  WORK    (workspace/output) COMPLEX 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+M+P).
+*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          CGEQRF, CGERQF, CUNMQR and CUNMRQ.
+*
+*          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 upper triangular factor R associated with A in the
+*                generalized QR factorization of the pair (A, B) is
+*                singular, so that rank(A) < M; the least squares
+*                solution could not be computed.
+*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal
+*                factor T associated with B in the generalized QR
+*                factorization of the pair (A, B) is singular, so that
+*                rank( A B ) < N; the least squares solution could not
+*                be computed.
+*
+*  ===================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
+     $                   NB4, NP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMV, CGGQRF, CTRTRS, CUNMQR, CUNMRQ,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NP = MIN( N, P )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'CGEQRF', ' ', N, M, -1, -1 )
+            NB2 = ILAENV( 1, 'CGERQF', ' ', N, M, -1, -1 )
+            NB3 = ILAENV( 1, 'CUNMQR', ' ', N, M, P, -1 )
+            NB4 = ILAENV( 1, 'CUNMRQ', ' ', N, M, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = M + NP + MAX( N, P )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGGLM', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GQR factorization of matrices A and B:
+*
+*            Q'*A = ( R11 ) M,    Q'*B*Z' = ( T11   T12 ) M
+*                   (  0  ) N-M             (  0    T22 ) N-M
+*                      M                     M+P-N  N-M
+*
+*     where R11 and T22 are upper triangular, and Q and Z are
+*     unitary.
+*
+      CALL CGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
+     $             WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = WORK( M+NP+1 )
+*
+*     Update left-hand-side vector d = Q'*d = ( d1 ) M
+*                                             ( d2 ) N-M
+*
+      CALL CUNMQR( 'Left', 'Conjugate transpose', N, 1, M, A, LDA, WORK,
+     $             D, MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+*     Solve T22*y2 = d2 for y2
+*
+      IF( N.GT.M ) THEN
+         CALL CTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
+     $                B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+         CALL CCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
+      END IF
+*
+*     Set y1 = 0
+*
+      DO 10 I = 1, M + P - N
+         Y( I ) = CZERO
+   10 CONTINUE
+*
+*     Update d1 = d1 - T12*y2
+*
+      CALL CGEMV( 'No transpose', M, N-M, -CONE, B( 1, M+P-N+1 ), LDB,
+     $            Y( M+P-N+1 ), 1, CONE, D, 1 )
+*
+*     Solve triangular system: R11*x = d1
+*
+      IF( M.GT.0 ) THEN
+         CALL CTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
+     $                D, M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Copy D to X
+*
+         CALL CCOPY( M, D, 1, X, 1 )
+      END IF
+*
+*     Backward transformation y = Z'*y
+*
+      CALL CUNMRQ( 'Left', 'Conjugate transpose', P, 1, NP,
+     $             B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
+     $             MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+      RETURN
+*
+*     End of CGGGLM
+*
+      END
diff --git a/SRC/cgghrd.f b/SRC/cgghrd.f
new file mode 100644
index 00000000..9bc4ca18
--- /dev/null
+++ b/SRC/cgghrd.f
@@ -0,0 +1,264 @@
+      SUBROUTINE CGGHRD( 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            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGHRD 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 CGGHRD 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 CGGBAL; 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 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 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 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 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            CONE, CZERO
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILQ, ILZ
+      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
+      REAL               C
+      COMPLEX            CTEMP, S
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARTG, CLASET, CROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CGGHRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z if desired.
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL CLASET( '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 CLARTG( CTEMP, A( JROW, JCOL ), C, S,
+     $                   A( JROW-1, JCOL ) )
+            A( JROW, JCOL ) = CZERO
+            CALL CROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
+     $                 A( JROW, JCOL+1 ), LDA, C, S )
+            CALL CROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
+     $                 B( JROW, JROW-1 ), LDB, C, S )
+            IF( ILQ )
+     $         CALL CROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C,
+     $                    CONJG( S ) )
+*
+*           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
+*
+            CTEMP = B( JROW, JROW )
+            CALL CLARTG( CTEMP, B( JROW, JROW-1 ), C, S,
+     $                   B( JROW, JROW ) )
+            B( JROW, JROW-1 ) = CZERO
+            CALL CROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
+            CALL CROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
+     $                 S )
+            IF( ILZ )
+     $         CALL CROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
+   30    CONTINUE
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of CGGHRD
+*
+      END
diff --git a/SRC/cgglse.f b/SRC/cgglse.f
new file mode 100644
index 00000000..0a8cc855
--- /dev/null
+++ b/SRC/cgglse.f
@@ -0,0 +1,267 @@
+      SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, 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, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), C( * ), D( * ),
+     $                   WORK( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGLSE solves the linear equality-constrained least squares (LSE)
+*  problem:
+*
+*          minimize || c - A*x ||_2   subject to   B*x = d
+*
+*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
+*  M-vector, and d is a given P-vector. It is assumed that
+*  P <= N <= M+P, and
+*
+*           rank(B) = P and  rank( (A) ) = N.
+*                                ( (B) )
+*
+*  These conditions ensure that the LSE problem has a unique solution,
+*  which is obtained using a generalized RQ factorization of the
+*  matrices (B, A) given by
+*
+*     B = (0 R)*Q,   A = Z*T*Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B. 0 <= P <= N <= M+P.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(M,N)-by-N upper trapezoidal matrix T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
+*          contains the P-by-P upper triangular matrix R.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  C       (input/output) COMPLEX array, dimension (M)
+*          On entry, C contains the right hand side vector for the
+*          least squares part of the LSE problem.
+*          On exit, the residual sum of squares for the solution
+*          is given by the sum of squares of elements N-P+1 to M of
+*          vector C.
+*
+*  D       (input/output) COMPLEX array, dimension (P)
+*          On entry, D contains the right hand side vector for the
+*          constrained equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) COMPLEX array, dimension (N)
+*          On exit, X is the solution of the LSE problem.
+*
+*  WORK    (workspace/output) COMPLEX 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+N+P).
+*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          CGEQRF, CGERQF, CUNMQR and CUNMRQ.
+*
+*          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 upper triangular factor R associated with B in the
+*                generalized RQ factorization of the pair (B, A) is
+*                singular, so that rank(B) < P; the least squares
+*                solution could not be computed.
+*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor
+*                T associated with A in the generalized RQ factorization
+*                of the pair (B, A) is singular, so that
+*                rank( (A) ) < N; the least squares solution could not
+*                    ( (B) )
+*                be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
+     $                   NB4, NR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMV, CGGRQF, CTRMV, CTRTRS,
+     $                   CUNMQR, CUNMRQ, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'CGEQRF', ' ', M, N, -1, -1 )
+            NB2 = ILAENV( 1, 'CGERQF', ' ', M, N, -1, -1 )
+            NB3 = ILAENV( 1, 'CUNMQR', ' ', M, N, P, -1 )
+            NB4 = ILAENV( 1, 'CUNMRQ', ' ', M, N, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = P + MN + MAX( M, N )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGLSE', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GRQ factorization of matrices B and A:
+*
+*            B*Q' = (  0  T12 ) P   Z'*A*Q' = ( R11 R12 ) N-P
+*                     N-P  P                  (  0  R22 ) M+P-N
+*                                               N-P  P
+*
+*     where T12 and R11 are upper triangular, and Q and Z are
+*     unitary.
+*
+      CALL CGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
+     $             WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      LOPT = WORK( P+MN+1 )
+*
+*     Update c = Z'*c = ( c1 ) N-P
+*                       ( c2 ) M+P-N
+*
+      CALL CUNMQR( 'Left', 'Conjugate Transpose', M, 1, MN, A, LDA,
+     $             WORK( P+1 ), C, MAX( 1, M ), WORK( P+MN+1 ),
+     $             LWORK-P-MN, INFO )
+      LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+*     Solve T12*x2 = d for x2
+*
+      IF( P.GT.0 ) THEN
+         CALL CTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
+     $                B( 1, N-P+1 ), LDB, D, P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+*        Put the solution in X
+*
+      CALL CCOPY( P, D, 1, X( N-P+1 ), 1 )
+*
+*        Update c1
+*
+         CALL CGEMV( 'No transpose', N-P, P, -CONE, A( 1, N-P+1 ), LDA,
+     $               D, 1, CONE, C, 1 )
+      END IF
+*
+*     Solve R11*x1 = c1 for x1
+*
+      IF( N.GT.P ) THEN
+         CALL CTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
+     $                A, LDA, C, N-P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Put the solutions in X
+*
+         CALL CCOPY( N-P, C, 1, X, 1 )
+      END IF
+*
+*     Compute the residual vector:
+*
+      IF( M.LT.N ) THEN
+         NR = M + P - N
+         IF( NR.GT.0 )
+     $      CALL CGEMV( 'No transpose', NR, N-M, -CONE, A( N-P+1, M+1 ),
+     $                  LDA, D( NR+1 ), 1, CONE, C( N-P+1 ), 1 )
+      ELSE
+         NR = P
+      END IF
+      IF( NR.GT.0 ) THEN
+         CALL CTRMV( 'Upper', 'No transpose', 'Non unit', NR,
+     $               A( N-P+1, N-P+1 ), LDA, D, 1 )
+         CALL CAXPY( NR, -CONE, D, 1, C( N-P+1 ), 1 )
+      END IF
+*
+*     Backward transformation x = Q'*x
+*
+      CALL CUNMRQ( 'Left', 'Conjugate Transpose', N, 1, P, B, LDB,
+     $             WORK( 1 ), X, N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+      RETURN
+*
+*     End of CGGLSE
+*
+      END
diff --git a/SRC/cggqrf.f b/SRC/cggqrf.f
new file mode 100644
index 00000000..380b8537
--- /dev/null
+++ b/SRC/cggqrf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGQRF computes a generalized QR factorization of an N-by-M matrix A
+*  and an N-by-P matrix B:
+*
+*              A = Q*R,        B = Q*T*Z,
+*
+*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,
+*  and R and T assume one of the forms:
+*
+*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
+*                  (  0  ) N-M                         N   M-N
+*                     M
+*
+*  where R11 is upper triangular, and
+*
+*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
+*                   P-N  N                           ( T21 ) P
+*                                                       P
+*
+*  where T12 or T21 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GQR factorization
+*  of A and B implicitly gives the QR factorization of inv(B)*A:
+*
+*               inv(B)*A = Z'*(inv(T)*R)
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  conjugate transpose of matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B. N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
+*          upper triangular if N >= M); the elements below the diagonal,
+*          with the array TAUA, represent the unitary matrix Q as a
+*          product of min(N,M) elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAUA    (output) COMPLEX array, dimension (min(N,M))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q (see Further Details).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)-th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T; the remaining
+*          elements, with the array TAUB, represent the unitary
+*          matrix Z as a product of elementary reflectors (see Further
+*          Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  TAUB    (output) COMPLEX array, dimension (min(N,P))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Z (see Further Details).
+*
+*  WORK    (workspace/output) COMPLEX 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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the QR factorization
+*          of an N-by-M matrix, NB2 is the optimal blocksize for the
+*          RQ factorization of an N-by-P matrix, and NB3 is the optimal
+*          blocksize for a call of CUNMQR.
+*
+*          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(n,m).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taua * v * v'
+*
+*  where taua is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+*  and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine CUNGQR.
+*  To use Q to update another matrix, use LAPACK subroutine CUNMQR.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(n,p).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a complex scalar, and v is a complex vector with
+*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
+*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine CUNGRQ.
+*  To use Z to update another matrix, use LAPACK subroutine CUNMRQ.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGERQF, CUNMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV 
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'CGEQRF', ' ', N, M, -1, -1 )
+      NB2 = ILAENV( 1, 'CGERQF', ' ', N, P, -1, -1 )
+      NB3 = ILAENV( 1, 'CUNMQR', ' ', N, M, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P)*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     QR factorization of N-by-M matrix A: A = Q*R
+*
+      CALL CGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := Q'*B.
+*
+      CALL CUNMQR( 'Left', 'Conjugate Transpose', N, P, MIN( N, M ), A,
+     $             LDA, TAUA, B, LDB, WORK, LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     RQ factorization of N-by-P matrix B: B = T*Z.
+*
+      CALL CGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of CGGQRF
+*
+      END
diff --git a/SRC/cggrqf.f b/SRC/cggrqf.f
new file mode 100644
index 00000000..9530d65f
--- /dev/null
+++ b/SRC/cggrqf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGRQF computes a generalized RQ factorization of an M-by-N matrix A
+*  and a P-by-N matrix B:
+*
+*              A = R*Q,        B = Z*T*Q,
+*
+*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary
+*  matrix, and R and T assume one of the forms:
+*
+*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
+*                   N-M  M                           ( R21 ) N
+*                                                       N
+*
+*  where R12 or R21 is upper triangular, and
+*
+*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
+*                  (  0  ) P-N                         P   N-P
+*                     N
+*
+*  where T11 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GRQ factorization
+*  of A and B implicitly gives the RQ factorization of A*inv(B):
+*
+*               A*inv(B) = (R*inv(T))*Z'
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  conjugate transpose of the matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, if M <= N, the upper triangle of the subarray
+*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
+*          if M > N, the elements on and above the (M-N)-th subdiagonal
+*          contain the M-by-N upper trapezoidal matrix R; the remaining
+*          elements, with the array TAUA, represent the 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).
+*
+*  TAUA    (output) COMPLEX array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q (see Further Details).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
+*          upper triangular if P >= N); the elements below the diagonal,
+*          with the array TAUB, represent the unitary matrix Z as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TAUB    (output) COMPLEX array, dimension (min(P,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Z (see Further Details).
+*
+*  WORK    (workspace/output) COMPLEX 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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the RQ factorization
+*          of an M-by-N matrix, NB2 is the optimal blocksize for the
+*          QR factorization of a P-by-N matrix, and NB3 is the optimal
+*          blocksize for a call of CUNMRQ.
+*
+*          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 - taua * v * v'
+*
+*  where taua is a complex scalar, and v is a complex vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine CUNGRQ.
+*  To use Q to update another matrix, use LAPACK subroutine CUNMRQ.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(p,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
+*  and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine CUNGQR.
+*  To use Z to update another matrix, use LAPACK subroutine CUNMQR.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQRF, CGERQF, CUNMRQ, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV 
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'CGERQF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'CGEQRF', ' ', P, N, -1, -1 )
+      NB3 = ILAENV( 1, 'CUNMRQ', ' ', M, N, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P)*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGRQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     RQ factorization of M-by-N matrix A: A = R*Q
+*
+      CALL CGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := B*Q'
+*
+      CALL CUNMRQ( 'Right', 'Conjugate Transpose', P, N, MIN( M, N ),
+     $             A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
+     $             LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     QR factorization of P-by-N matrix B: B = Z*T
+*
+      CALL CGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of CGGRQF
+*
+      END
diff --git a/SRC/cggsvd.f b/SRC/cggsvd.f
new file mode 100644
index 00000000..416be61b
--- /dev/null
+++ b/SRC/cggsvd.f
@@ -0,0 +1,333 @@
+      SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
+     $                   LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
+     $                   RWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               ALPHA( * ), BETA( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGSVD computes the generalized singular value decomposition (GSVD)
+*  of an M-by-N complex matrix A and P-by-N complex matrix B:
+*
+*        U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )
+*
+*  where U, V and Q are unitary matrices, and Z' means the conjugate
+*  transpose of Z.  Let K+L = the effective numerical rank of the
+*  matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper
+*  triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal"
+*  matrices and of the following structures, respectively:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                    K  L
+*         D2 =   L ( 0  S )
+*              P-L ( 0  0 )
+*
+*                  N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 )
+*              L (  0    0   R22 )
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                    K M-K K+L-M
+*         D1 =   K ( I  0    0   )
+*              M-K ( 0  C    0   )
+*
+*                      K M-K K+L-M
+*         D2 =   M-K ( 0  S    0  )
+*              K+L-M ( 0  0    I  )
+*                P-L ( 0  0    0  )
+*
+*                     N-K-L  K   M-K  K+L-M
+*    ( 0 R ) =     K ( 0    R11  R12  R13  )
+*                M-K ( 0     0   R22  R23  )
+*              K+L-M ( 0     0    0   R33  )
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*    S = diag( BETA(K+1),  ... , BETA(M) ),
+*    C**2 + S**2 = I.
+*
+*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
+*    ( 0  R22 R23 )
+*    in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The routine computes C, S, R, and optionally the unitary
+*  transformation matrices U, V and Q.
+*
+*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
+*  A and B implicitly gives the SVD of A*inv(B):
+*                       A*inv(B) = U*(D1*inv(D2))*V'.
+*  If ( A',B')' has orthnormal columns, then the GSVD of A and B is also
+*  equal to the CS decomposition of A and B. Furthermore, the GSVD can
+*  be used to derive the solution of the eigenvalue problem:
+*                       A'*A x = lambda* B'*B x.
+*  In some literature, the GSVD of A and B is presented in the form
+*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )
+*  where U and V are orthogonal and X is nonsingular, and D1 and D2 are
+*  ``diagonal''.  The former GSVD form can be converted to the latter
+*  form by taking the nonsingular matrix X as
+*
+*                        X = Q*(  I   0    )
+*                              (  0 inv(R) )
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Unitary matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Unitary matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Unitary matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in Purpose.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular matrix R, or part of R.
+*          See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains part of the triangular matrix R if
+*          M-K-L < 0.  See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  ALPHA   (output) REAL array, dimension (N)
+*  BETA    (output) REAL array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = C,
+*            BETA(K+1:K+L)  = S,
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1
+*          and
+*            ALPHA(K+L+1:N) = 0
+*            BETA(K+L+1:N)  = 0
+*
+*  U       (output) COMPLEX array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the M-by-M unitary matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) COMPLEX array, dimension (LDV,P)
+*          If JOBV = 'V', V contains the P-by-P unitary matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) COMPLEX array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX array, dimension (max(3*N,M,P)+N)
+*
+*  RWORK   (workspace) REAL array, dimension (2*N)
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (N)
+*          On exit, IWORK stores the sorting information. More
+*          precisely, the following loop will sort ALPHA
+*             for I = K+1, min(M,K+L)
+*                 swap ALPHA(I) and ALPHA(IWORK(I))
+*             endfor
+*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, the Jacobi-type procedure failed to
+*                converge.  For further details, see subroutine CTGSJA.
+*
+*  Internal Parameters
+*  ===================
+*
+*  TOLA    REAL
+*  TOLB    REAL
+*          TOLA and TOLB are the thresholds to determine the effective
+*          rank of (A',B')'. Generally, they are set to
+*                   TOLA = MAX(M,N)*norm(A)*MACHEPS,
+*                   TOLB = MAX(P,N)*norm(B)*MACHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  Further Details
+*  ===============
+*
+*  2-96 Based on modifications by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            WANTQ, WANTU, WANTV
+      INTEGER            I, IBND, ISUB, J, NCYCLE
+      REAL               ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANGE, SLAMCH
+      EXTERNAL           LSAME, CLANGE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGGSVP, CTGSJA, SCOPY, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGSVD', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Frobenius norm of matrices A and B
+*
+      ANORM = CLANGE( '1', M, N, A, LDA, RWORK )
+      BNORM = CLANGE( '1', P, N, B, LDB, RWORK )
+*
+*     Get machine precision and set up threshold for determining
+*     the effective numerical rank of the matrices A and B.
+*
+      ULP = SLAMCH( 'Precision' )
+      UNFL = SLAMCH( 'Safe Minimum' )
+      TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
+      TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
+*
+      CALL CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
+     $             TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK,
+     $             WORK, WORK( N+1 ), INFO )
+*
+*     Compute the GSVD of two upper "triangular" matrices
+*
+      CALL CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB,
+     $             TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
+     $             WORK, NCYCLE, INFO )
+*
+*     Sort the singular values and store the pivot indices in IWORK
+*     Copy ALPHA to RWORK, then sort ALPHA in RWORK
+*
+      CALL SCOPY( N, ALPHA, 1, RWORK, 1 )
+      IBND = MIN( L, M-K )
+      DO 20 I = 1, IBND
+*
+*        Scan for largest ALPHA(K+I)
+*
+         ISUB = I
+         SMAX = RWORK( K+I )
+         DO 10 J = I + 1, IBND
+            TEMP = RWORK( K+J )
+            IF( TEMP.GT.SMAX ) THEN
+               ISUB = J
+               SMAX = TEMP
+            END IF
+   10    CONTINUE
+         IF( ISUB.NE.I ) THEN
+            RWORK( K+ISUB ) = RWORK( K+I )
+            RWORK( K+I ) = SMAX
+            IWORK( K+I ) = K + ISUB
+         ELSE
+            IWORK( K+I ) = K + I
+         END IF
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of CGGSVD
+*
+      END
diff --git a/SRC/cggsvp.f b/SRC/cggsvp.f
new file mode 100644
index 00000000..5aafb5fd
--- /dev/null
+++ b/SRC/cggsvp.f
@@ -0,0 +1,402 @@
+      SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
+     $                   TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,
+     $                   IWORK, RWORK, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+      REAL               TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGGSVP computes unitary matrices U, V and Q such that
+*
+*                   N-K-L  K    L
+*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
+*                L ( 0     0   A23 )
+*            M-K-L ( 0     0    0  )
+*
+*                   N-K-L  K    L
+*          =     K ( 0    A12  A13 )  if M-K-L < 0;
+*              M-K ( 0     0   A23 )
+*
+*                 N-K-L  K    L
+*   V'*B*Q =   L ( 0     0   B13 )
+*            P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
+*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the
+*  conjugate transpose of Z.
+*
+*  This decomposition is the preprocessing step for computing the
+*  Generalized Singular Value Decomposition (GSVD), see subroutine
+*  CGGSVD.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Unitary matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Unitary matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Unitary matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular (or trapezoidal) matrix
+*          described in the Purpose section.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains the triangular matrix described in
+*          the Purpose section.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) REAL
+*  TOLB    (input) REAL
+*          TOLA and TOLB are the thresholds to determine the effective
+*          numerical rank of matrix B and a subblock of A. Generally,
+*          they are set to
+*             TOLA = MAX(M,N)*norm(A)*MACHEPS,
+*             TOLB = MAX(P,N)*norm(B)*MACHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in Purpose section.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  U       (output) COMPLEX array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the unitary matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) COMPLEX array, dimension (LDV,M)
+*          If JOBV = 'V', V contains the unitary matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) COMPLEX array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the unitary matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  RWORK   (workspace) REAL array, dimension (2*N)
+*
+*  TAU     (workspace) COMPLEX array, dimension (N)
+*
+*  WORK    (workspace) COMPLEX array, dimension (max(3*N,M,P))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The subroutine uses LAPACK subroutine CGEQPF for the QR factorization
+*  with column pivoting to detect the effective numerical rank of the
+*  a matrix. It may be replaced by a better rank determination strategy.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORWRD, WANTQ, WANTU, WANTV
+      INTEGER            I, J
+      COMPLEX            T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEQPF, CGEQR2, CGERQ2, CLACPY, CLAPMT, CLASET,
+     $                   CUNG2R, CUNM2R, CUNMR2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( T ) = ABS( REAL( T ) ) + ABS( AIMAG( T ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+      FORWRD = .TRUE.
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -10
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGGSVP', -INFO )
+         RETURN
+      END IF
+*
+*     QR with column pivoting of B: B*P = V*( S11 S12 )
+*                                           (  0   0  )
+*
+      DO 10 I = 1, N
+         IWORK( I ) = 0
+   10 CONTINUE
+      CALL CGEQPF( P, N, B, LDB, IWORK, TAU, WORK, RWORK, INFO )
+*
+*     Update A := A*P
+*
+      CALL CLAPMT( FORWRD, M, N, A, LDA, IWORK )
+*
+*     Determine the effective rank of matrix B.
+*
+      L = 0
+      DO 20 I = 1, MIN( P, N )
+         IF( CABS1( B( I, I ) ).GT.TOLB )
+     $      L = L + 1
+   20 CONTINUE
+*
+      IF( WANTV ) THEN
+*
+*        Copy the details of V, and form V.
+*
+         CALL CLASET( 'Full', P, P, CZERO, CZERO, V, LDV )
+         IF( P.GT.1 )
+     $      CALL CLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
+     $                   LDV )
+         CALL CUNG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
+      END IF
+*
+*     Clean up B
+*
+      DO 40 J = 1, L - 1
+         DO 30 I = J + 1, L
+            B( I, J ) = CZERO
+   30    CONTINUE
+   40 CONTINUE
+      IF( P.GT.L )
+     $   CALL CLASET( 'Full', P-L, N, CZERO, CZERO, B( L+1, 1 ), LDB )
+*
+      IF( WANTQ ) THEN
+*
+*        Set Q = I and Update Q := Q*P
+*
+         CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+         CALL CLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
+      END IF
+*
+      IF( P.GE.L .AND. N.NE.L ) THEN
+*
+*        RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z
+*
+         CALL CGERQ2( L, N, B, LDB, TAU, WORK, INFO )
+*
+*        Update A := A*Z'
+*
+         CALL CUNMR2( 'Right', 'Conjugate transpose', M, N, L, B, LDB,
+     $                TAU, A, LDA, WORK, INFO )
+         IF( WANTQ ) THEN
+*
+*           Update Q := Q*Z'
+*
+            CALL CUNMR2( 'Right', 'Conjugate transpose', N, N, L, B,
+     $                   LDB, TAU, Q, LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up B
+*
+         CALL CLASET( 'Full', L, N-L, CZERO, CZERO, B, LDB )
+         DO 60 J = N - L + 1, N
+            DO 50 I = J - N + L + 1, L
+               B( I, J ) = CZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+      END IF
+*
+*     Let              N-L     L
+*                A = ( A11    A12 ) M,
+*
+*     then the following does the complete QR decomposition of A11:
+*
+*              A11 = U*(  0  T12 )*P1'
+*                      (  0   0  )
+*
+      DO 70 I = 1, N - L
+         IWORK( I ) = 0
+   70 CONTINUE
+      CALL CGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, RWORK, INFO )
+*
+*     Determine the effective rank of A11
+*
+      K = 0
+      DO 80 I = 1, MIN( M, N-L )
+         IF( CABS1( A( I, I ) ).GT.TOLA )
+     $      K = K + 1
+   80 CONTINUE
+*
+*     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
+*
+      CALL CUNM2R( 'Left', 'Conjugate transpose', M, L, MIN( M, N-L ),
+     $             A, LDA, TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
+*
+      IF( WANTU ) THEN
+*
+*        Copy the details of U, and form U
+*
+         CALL CLASET( 'Full', M, M, CZERO, CZERO, U, LDU )
+         IF( M.GT.1 )
+     $      CALL CLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
+     $                   LDU )
+         CALL CUNG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
+      END IF
+*
+      IF( WANTQ ) THEN
+*
+*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1
+*
+         CALL CLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
+      END IF
+*
+*     Clean up A: set the strictly lower triangular part of
+*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
+*
+      DO 100 J = 1, K - 1
+         DO 90 I = J + 1, K
+            A( I, J ) = CZERO
+   90    CONTINUE
+  100 CONTINUE
+      IF( M.GT.K )
+     $   CALL CLASET( 'Full', M-K, N-L, CZERO, CZERO, A( K+1, 1 ), LDA )
+*
+      IF( N-L.GT.K ) THEN
+*
+*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
+*
+         CALL CGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
+*
+         IF( WANTQ ) THEN
+*
+*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
+*
+            CALL CUNMR2( 'Right', 'Conjugate transpose', N, N-L, K, A,
+     $                   LDA, TAU, Q, LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up A
+*
+         CALL CLASET( 'Full', K, N-L-K, CZERO, CZERO, A, LDA )
+         DO 120 J = N - L - K + 1, N - L
+            DO 110 I = J - N + L + K + 1, K
+               A( I, J ) = CZERO
+  110       CONTINUE
+  120    CONTINUE
+*
+      END IF
+*
+      IF( M.GT.K ) THEN
+*
+*        QR factorization of A( K+1:M,N-L+1:N )
+*
+         CALL CGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
+*
+         IF( WANTU ) THEN
+*
+*           Update U(:,K+1:M) := U(:,K+1:M)*U1
+*
+            CALL CUNM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
+     $                   A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
+     $                   WORK, INFO )
+         END IF
+*
+*        Clean up
+*
+         DO 140 J = N - L + 1, N
+            DO 130 I = J - N + K + L + 1, M
+               A( I, J ) = CZERO
+  130       CONTINUE
+  140    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of CGGSVP
+*
+      END
diff --git a/SRC/cgtcon.f b/SRC/cgtcon.f
new file mode 100644
index 00000000..cf54a837
--- /dev/null
+++ b/SRC/cgtcon.f
@@ -0,0 +1,171 @@
+      SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTCON estimates the reciprocal of the condition number of a complex
+*  tridiagonal matrix A using the LU factorization as computed by
+*  CGTTRF.
+*
+*  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
+*  =========
+*
+*  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.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by CGTTRF.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) COMPLEX array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  ANORM   (input) REAL
+*          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) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ONENRM
+      INTEGER            I, KASE, KASE1
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGTTRS, CLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is non-zero.
+*
+      DO 10 I = 1, N
+         IF( D( I ).EQ.CMPLX( ZERO ) )
+     $      RETURN
+   10 CONTINUE
+*
+      AINVNM = ZERO
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KASE = 0
+   20 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(U)*inv(L).
+*
+            CALL CGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
+     $                   WORK, N, INFO )
+         ELSE
+*
+*           Multiply by inv(L')*inv(U').
+*
+            CALL CGTTRS( 'Conjugate transpose', N, 1, DL, D, DU, DU2,
+     $                   IPIV, WORK, N, INFO )
+         END IF
+         GO TO 20
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of CGTCON
+*
+      END
diff --git a/SRC/cgtrfs.f b/SRC/cgtrfs.f
new file mode 100644
index 00000000..4794b460
--- /dev/null
+++ b/SRC/cgtrfs.f
@@ -0,0 +1,373 @@
+      SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
+     $                   IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            B( LDB, * ), D( * ), DF( * ), DL( * ),
+     $                   DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is tridiagonal, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input) COMPLEX array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by CGTTRF.
+*
+*  DF      (input) COMPLEX array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DUF     (input) COMPLEX array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) COMPLEX array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CGTTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGTTRS, CLACN2, CLAGTM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -15
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 110 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
+     $                WORK, N )
+*
+*        Compute abs(op(A))*abs(x) + abs(b) for use in the backward
+*        error bound.
+*
+         IF( NOTRAN ) THEN
+            IF( N.EQ.1 ) THEN
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) )
+            ELSE
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
+     $                      CABS1( DU( 1 ) )*CABS1( X( 2, J ) )
+               DO 30 I = 2, N - 1
+                  RWORK( I ) = CABS1( B( I, J ) ) +
+     $                         CABS1( DL( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( D( I ) )*CABS1( X( I, J ) ) +
+     $                         CABS1( DU( I ) )*CABS1( X( I+1, J ) )
+   30          CONTINUE
+               RWORK( N ) = CABS1( B( N, J ) ) +
+     $                      CABS1( DL( N-1 ) )*CABS1( X( N-1, J ) ) +
+     $                      CABS1( D( N ) )*CABS1( X( N, J ) )
+            END IF
+         ELSE
+            IF( N.EQ.1 ) THEN
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) )
+            ELSE
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
+     $                      CABS1( DL( 1 ) )*CABS1( X( 2, J ) )
+               DO 40 I = 2, N - 1
+                  RWORK( I ) = CABS1( B( I, J ) ) +
+     $                         CABS1( DU( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( D( I ) )*CABS1( X( I, J ) ) +
+     $                         CABS1( DL( I ) )*CABS1( X( I+1, J ) )
+   40          CONTINUE
+               RWORK( N ) = CABS1( B( N, J ) ) +
+     $                      CABS1( DU( N-1 ) )*CABS1( X( N-1, J ) ) +
+     $                      CABS1( D( N ) )*CABS1( X( N, J ) )
+            END IF
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 50 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+   50    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL CGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, WORK, N,
+     $                   INFO )
+            CALL CAXPY( N, CMPLX( ONE ), WORK, 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 CLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 60 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   60    CONTINUE
+*
+         KASE = 0
+   70    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL CGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
+     $                      N, INFO )
+               DO 80 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+   80          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 90 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+   90          CONTINUE
+               CALL CGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
+     $                      N, INFO )
+            END IF
+            GO TO 70
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 100 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  100    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of CGTRFS
+*
+      END
diff --git a/SRC/cgtsv.f b/SRC/cgtsv.f
new file mode 100644
index 00000000..cde1ce9b
--- /dev/null
+++ b/SRC/cgtsv.f
@@ -0,0 +1,173 @@
+      SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            B( LDB, * ), D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTSV  solves the equation
+*
+*     A*X = B,
+*
+*  where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
+*  partial pivoting.
+*
+*  Note that the equation  A'*X = B  may be solved by interchanging the
+*  order of the arguments DU and DL.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  DL      (input/output) COMPLEX array, dimension (N-1)
+*          On entry, DL must contain the (n-1) subdiagonal elements of
+*          A.
+*          On exit, DL is overwritten by the (n-2) elements of the
+*          second superdiagonal of the upper triangular matrix U from
+*          the LU factorization of A, in DL(1), ..., DL(n-2).
+*
+*  D       (input/output) COMPLEX array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*          On exit, D is overwritten by the n diagonal elements of U.
+*
+*  DU      (input/output) COMPLEX array, dimension (N-1)
+*          On entry, DU must contain the (n-1) superdiagonal elements
+*          of A.
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          superdiagonal of U.
+*
+*  B       (input/output) COMPLEX 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).
+*
+*  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, and the solution
+*                has not been computed.  The factorization has not been
+*                completed unless i = N.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, K
+      COMPLEX            MULT, TEMP, ZDUM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGTSV ', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      DO 30 K = 1, N - 1
+         IF( DL( K ).EQ.ZERO ) THEN
+*
+*           Subdiagonal is zero, no elimination is required.
+*
+            IF( D( K ).EQ.ZERO ) THEN
+*
+*              Diagonal is zero: set INFO = K and return; a unique
+*              solution can not be found.
+*
+               INFO = K
+               RETURN
+            END IF
+         ELSE IF( CABS1( D( K ) ).GE.CABS1( DL( K ) ) ) THEN
+*
+*           No row interchange required
+*
+            MULT = DL( K ) / D( K )
+            D( K+1 ) = D( K+1 ) - MULT*DU( K )
+            DO 10 J = 1, NRHS
+               B( K+1, J ) = B( K+1, J ) - MULT*B( K, J )
+   10       CONTINUE
+            IF( K.LT.( N-1 ) )
+     $         DL( K ) = ZERO
+         ELSE
+*
+*           Interchange rows K and K+1
+*
+            MULT = D( K ) / DL( K )
+            D( K ) = DL( K )
+            TEMP = D( K+1 )
+            D( K+1 ) = DU( K ) - MULT*TEMP
+            IF( K.LT.( N-1 ) ) THEN
+               DL( K ) = DU( K+1 )
+               DU( K+1 ) = -MULT*DL( K )
+            END IF
+            DU( K ) = TEMP
+            DO 20 J = 1, NRHS
+               TEMP = B( K, J )
+               B( K, J ) = B( K+1, J )
+               B( K+1, J ) = TEMP - MULT*B( K+1, J )
+   20       CONTINUE
+         END IF
+   30 CONTINUE
+      IF( D( N ).EQ.ZERO ) THEN
+         INFO = N
+         RETURN
+      END IF
+*
+*     Back solve with the matrix U from the factorization.
+*
+      DO 50 J = 1, NRHS
+         B( N, J ) = B( N, J ) / D( N )
+         IF( N.GT.1 )
+     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
+         DO 40 K = N - 2, 1, -1
+            B( K, J ) = ( B( K, J )-DU( K )*B( K+1, J )-DL( K )*
+     $                  B( K+2, J ) ) / D( K )
+   40    CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of CGTSV
+*
+      END
diff --git a/SRC/cgtsvx.f b/SRC/cgtsvx.f
new file mode 100644
index 00000000..4e73b7fb
--- /dev/null
+++ b/SRC/cgtsvx.f
@@ -0,0 +1,292 @@
+      SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
+     $                   DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            B( LDB, * ), D( * ), DF( * ), DL( * ),
+     $                   DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTSVX uses the LU factorization to compute the solution to a complex
+*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A
+*     as A = L * U, where L is a product of permutation and unit lower
+*     bidiagonal matrices and U is upper triangular with nonzeros in
+*     only the main diagonal and first two superdiagonals.
+*
+*  2. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored form
+*                  of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not
+*                  be modified.
+*          = 'N':  The matrix will be copied to DLF, DF, and DUF
+*                  and factored.
+*
+*  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.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The n diagonal elements of A.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input or output) COMPLEX array, dimension (N-1)
+*          If FACT = 'F', then DLF is an input argument and on entry
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A as computed by CGTTRF.
+*
+*          If FACT = 'N', then DLF is an output argument and on exit
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A.
+*
+*  DF      (input or output) COMPLEX array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*  DUF     (input or output) COMPLEX array, dimension (N-1)
+*          If FACT = 'F', then DUF is an input argument and on entry
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*          If FACT = 'N', then DUF is an output argument and on exit
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input or output) COMPLEX array, dimension (N-2)
+*          If FACT = 'F', then DU2 is an input argument and on entry
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*          If FACT = 'N', then DU2 is an output argument and on exit
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*  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 LU factorization of A as
+*          computed by CGTTRF.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the LU factorization of A;
+*          row i of the matrix was interchanged with row IPIV(i).
+*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
+*          a row interchange was not required.
+*
+*  B       (input) COMPLEX array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 not been completed unless i = N, but the
+*                       factor U is exactly singular, so the solution
+*                       and error bounds could not be computed.
+*                       RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT, NOTRAN
+      CHARACTER          NORM
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANGT, SLAMCH
+      EXTERNAL           LSAME, CLANGT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGTCON, CGTRFS, CGTTRF, CGTTRS, CLACPY,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the LU factorization of A.
+*
+         CALL CCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 ) THEN
+            CALL CCOPY( N-1, DL, 1, DLF, 1 )
+            CALL CCOPY( N-1, DU, 1, DUF, 1 )
+         END IF
+         CALL CGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = CLANGT( NORM, N, DL, D, DU )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
+     $             INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CGTSVX
+*
+      END
diff --git a/SRC/cgttrf.f b/SRC/cgttrf.f
new file mode 100644
index 00000000..914e3266
--- /dev/null
+++ b/SRC/cgttrf.f
@@ -0,0 +1,174 @@
+      SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, 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 ..
+      INTEGER            IPIV( * )
+      COMPLEX            D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTTRF computes an LU factorization of a complex tridiagonal matrix A
+*  using elimination with partial pivoting and row interchanges.
+*
+*  The factorization has the form
+*     A = L * U
+*  where L is a product of permutation and unit lower bidiagonal
+*  matrices and U is upper triangular with nonzeros in only the main
+*  diagonal and first two superdiagonals.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  DL      (input/output) COMPLEX array, dimension (N-1)
+*          On entry, DL must contain the (n-1) sub-diagonal elements of
+*          A.
+*
+*          On exit, DL is overwritten by the (n-1) multipliers that
+*          define the matrix L from the LU factorization of A.
+*
+*  D       (input/output) COMPLEX array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*
+*          On exit, D is overwritten by the n diagonal elements of the
+*          upper triangular matrix U from the LU factorization of A.
+*
+*  DU      (input/output) COMPLEX array, dimension (N-1)
+*          On entry, DU must contain the (n-1) super-diagonal elements
+*          of A.
+*
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          super-diagonal of U.
+*
+*  DU2     (output) COMPLEX array, dimension (N-2)
+*          On exit, DU2 is overwritten by the (n-2) elements of the
+*          second super-diagonal of U.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            FACT, TEMP, ZDUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'CGTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize IPIV(i) = i and DU2(i) = 0
+*
+      DO 10 I = 1, N
+         IPIV( I ) = I
+   10 CONTINUE
+      DO 20 I = 1, N - 2
+         DU2( I ) = ZERO
+   20 CONTINUE
+*
+      DO 30 I = 1, N - 2
+         IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
+*
+*           No row interchange required, eliminate DL(I)
+*
+            IF( CABS1( D( I ) ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+*
+*           Interchange rows I and I+1, eliminate DL(I)
+*
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            DU2( I ) = DU( I+1 )
+            DU( I+1 ) = -FACT*DU( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+   30 CONTINUE
+      IF( N.GT.1 ) THEN
+         I = N - 1
+         IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
+            IF( CABS1( D( I ) ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+      END IF
+*
+*     Check for a zero on the diagonal of U.
+*
+      DO 40 I = 1, N
+         IF( CABS1( D( I ) ).EQ.ZERO ) THEN
+            INFO = I
+            GO TO 50
+         END IF
+   40 CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of CGTTRF
+*
+      END
diff --git a/SRC/cgttrs.f b/SRC/cgttrs.f
new file mode 100644
index 00000000..2da12aca
--- /dev/null
+++ b/SRC/cgttrs.f
@@ -0,0 +1,142 @@
+      SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTTRS solves one of the systems of equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by CGTTRF.
+*
+*  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.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) COMPLEX array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            ITRANS, J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGTTS2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
+      IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
+     $    't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CGTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Decode TRANS
+*
+      IF( NOTRAN ) THEN
+         ITRANS = 0
+      ELSE IF( TRANS.EQ.'T' .OR. TRANS.EQ.'t' ) THEN
+         ITRANS = 1
+      ELSE
+         ITRANS = 2
+      END IF
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'CGTTRS', TRANS, N, NRHS, -1, -1 ) )
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL CGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
+     $                   LDB )
+   10    CONTINUE
+      END IF
+*
+*     End of CGTTRS
+*
+      END
diff --git a/SRC/cgtts2.f b/SRC/cgtts2.f
new file mode 100644
index 00000000..840a9199
--- /dev/null
+++ b/SRC/cgtts2.f
@@ -0,0 +1,271 @@
+      SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ITRANS, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CGTTS2 solves one of the systems of equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by CGTTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITRANS  (input) INTEGER
+*          Specifies the form of the system of equations.
+*          = 0:  A * X = B     (No transpose)
+*          = 1:  A**T * X = B  (Transpose)
+*          = 2:  A**H * X = B  (Conjugate transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) COMPLEX array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+      COMPLEX            TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( ITRANS.EQ.0 ) THEN
+*
+*        Solve A*X = B using the LU factorization of A,
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+   10       CONTINUE
+*
+*           Solve L*x = b.
+*
+            DO 20 I = 1, N - 1
+               IF( IPIV( I ).EQ.I ) THEN
+                  B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+               ELSE
+                  TEMP = B( I, J )
+                  B( I, J ) = B( I+1, J )
+                  B( I+1, J ) = TEMP - DL( I )*B( I, J )
+               END IF
+   20       CONTINUE
+*
+*           Solve U*x = b.
+*
+            B( N, J ) = B( N, J ) / D( N )
+            IF( N.GT.1 )
+     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                       D( N-1 )
+            DO 30 I = N - 2, 1, -1
+               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                     B( I+2, J ) ) / D( I )
+   30       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 10
+            END IF
+         ELSE
+            DO 60 J = 1, NRHS
+*
+*           Solve L*x = b.
+*
+               DO 40 I = 1, N - 1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+                  ELSE
+                     TEMP = B( I, J )
+                     B( I, J ) = B( I+1, J )
+                     B( I+1, J ) = TEMP - DL( I )*B( I, J )
+                  END IF
+   40          CONTINUE
+*
+*           Solve U*x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               IF( N.GT.1 )
+     $            B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                          D( N-1 )
+               DO 50 I = N - 2, 1, -1
+                  B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                        B( I+2, J ) ) / D( I )
+   50          CONTINUE
+   60       CONTINUE
+         END IF
+      ELSE IF( ITRANS.EQ.1 ) THEN
+*
+*        Solve A**T * X = B.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+   70       CONTINUE
+*
+*           Solve U**T * x = b.
+*
+            B( 1, J ) = B( 1, J ) / D( 1 )
+            IF( N.GT.1 )
+     $         B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+            DO 80 I = 3, N
+               B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
+     $                     B( I-2, J ) ) / D( I )
+   80       CONTINUE
+*
+*           Solve L**T * x = b.
+*
+            DO 90 I = N - 1, 1, -1
+               IF( IPIV( I ).EQ.I ) THEN
+                  B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+               ELSE
+                  TEMP = B( I+1, J )
+                  B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+                  B( I, J ) = TEMP
+               END IF
+   90       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 70
+            END IF
+         ELSE
+            DO 120 J = 1, NRHS
+*
+*           Solve U**T * x = b.
+*
+               B( 1, J ) = B( 1, J ) / D( 1 )
+               IF( N.GT.1 )
+     $            B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+               DO 100 I = 3, N
+                  B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
+     $                        DU2( I-2 )*B( I-2, J ) ) / D( I )
+  100          CONTINUE
+*
+*           Solve L**T * x = b.
+*
+               DO 110 I = N - 1, 1, -1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+                  ELSE
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+                     B( I, J ) = TEMP
+                  END IF
+  110          CONTINUE
+  120       CONTINUE
+         END IF
+      ELSE
+*
+*        Solve A**H * X = B.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+  130       CONTINUE
+*
+*           Solve U**H * x = b.
+*
+            B( 1, J ) = B( 1, J ) / CONJG( D( 1 ) )
+            IF( N.GT.1 )
+     $         B( 2, J ) = ( B( 2, J )-CONJG( DU( 1 ) )*B( 1, J ) ) /
+     $                     CONJG( D( 2 ) )
+            DO 140 I = 3, N
+               B( I, J ) = ( B( I, J )-CONJG( DU( I-1 ) )*B( I-1, J )-
+     $                     CONJG( DU2( I-2 ) )*B( I-2, J ) ) /
+     $                     CONJG( D( I ) )
+  140       CONTINUE
+*
+*           Solve L**H * x = b.
+*
+            DO 150 I = N - 1, 1, -1
+               IF( IPIV( I ).EQ.I ) THEN
+                  B( I, J ) = B( I, J ) - CONJG( DL( I ) )*B( I+1, J )
+               ELSE
+                  TEMP = B( I+1, J )
+                  B( I+1, J ) = B( I, J ) - CONJG( DL( I ) )*TEMP
+                  B( I, J ) = TEMP
+               END IF
+  150       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 130
+            END IF
+         ELSE
+            DO 180 J = 1, NRHS
+*
+*           Solve U**H * x = b.
+*
+               B( 1, J ) = B( 1, J ) / CONJG( D( 1 ) )
+               IF( N.GT.1 )
+     $            B( 2, J ) = ( B( 2, J )-CONJG( DU( 1 ) )*B( 1, J ) ) /
+     $                        CONJG( D( 2 ) )
+               DO 160 I = 3, N
+                  B( I, J ) = ( B( I, J )-CONJG( DU( I-1 ) )*
+     $                        B( I-1, J )-CONJG( DU2( I-2 ) )*
+     $                        B( I-2, J ) ) / CONJG( D( I ) )
+  160          CONTINUE
+*
+*           Solve L**H * x = b.
+*
+               DO 170 I = N - 1, 1, -1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I, J ) = B( I, J ) - CONJG( DL( I ) )*
+     $                           B( I+1, J )
+                  ELSE
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - CONJG( DL( I ) )*TEMP
+                     B( I, J ) = TEMP
+                  END IF
+  170          CONTINUE
+  180       CONTINUE
+         END IF
+      END IF
+*
+*     End of CGTTS2
+*
+      END
diff --git a/SRC/chbev.f b/SRC/chbev.f
new file mode 100644
index 00000000..96b44423
--- /dev/null
+++ b/SRC/chbev.f
@@ -0,0 +1,208 @@
+      SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+     $                  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, KD, LDAB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AB( LDAB, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBEV computes all the eigenvalues and, optionally, eigenvectors of
+*  a complex Hermitian band 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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX 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) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, ISCALE
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHB, SLAMCH
+      EXTERNAL           LSAME, CLANHB, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHBTRD, CLASCL, CSTEQR, SSCAL, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            W( 1 ) = AB( 1, 1 )
+         ELSE
+            W( 1 ) = AB( KD+1, 1 )
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = CLANHB( 'M', UPLO, N, KD, AB, LDAB, 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 ) THEN
+         IF( LOWER ) THEN
+            CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call CHBTRD to reduce Hermitian band matrix to tridiagonal form.
+*
+      INDE = 1
+      CALL CHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call CSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         INDRWK = INDE + N
+         CALL CSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
+     $                RWORK( INDRWK ), 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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of CHBEV
+*
+      END
diff --git a/SRC/chbevd.f b/SRC/chbevd.f
new file mode 100644
index 00000000..e37bdd0f
--- /dev/null
+++ b/SRC/chbevd.f
@@ -0,0 +1,302 @@
+      SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+     $                   LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AB( LDAB, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBEVD computes all the eigenvalues and, optionally, eigenvectors of
+*  a complex Hermitian band matrix A.  If eigenvectors are desired, it
+*  uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX 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/output) COMPLEX 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 N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array,
+*                                         dimension (LRWORK)
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LRWORK must be at least
+*                        1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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 array IWORK.
+*          If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDWK2, INDWRK, ISCALE,
+     $                   LIWMIN, LLRWK, LLWK2, LRWMIN, LWMIN
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHB, SLAMCH
+      EXTERNAL           LSAME, CLANHB, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CHBTRD, CLACPY, CLASCL, CSTEDC, SSCAL,
+     $                   SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LWMIN = 1
+         LRWMIN = 1
+         LIWMIN = 1
+      ELSE
+         IF( WANTZ ) THEN
+            LWMIN = 2*N**2
+            LRWMIN = 1 + 5*N + 2*N**2
+            LIWMIN = 3 + 5*N
+         ELSE
+            LWMIN = N
+            LRWMIN = N
+            LIWMIN = 1
+         END IF
+      END IF
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN 
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AB( 1, 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = CONE
+         RETURN 
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = CLANHB( 'M', UPLO, N, KD, AB, LDAB, 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 ) THEN
+         IF( LOWER ) THEN
+            CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call CHBTRD to reduce Hermitian band matrix to tridiagonal form.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = 1 + N*N
+      LLWK2 = LWORK - INDWK2 + 1
+      LLRWK = LRWORK - INDWRK + 1
+      CALL CHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call CSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL CSTEDC( 'I', N, W, RWORK( INDE ), WORK, N, WORK( INDWK2 ),
+     $                LLWK2, RWORK( INDWRK ), LLRWK, IWORK, LIWORK,
+     $                INFO )
+         CALL CGEMM( 'N', 'N', N, N, N, CONE, Z, LDZ, WORK, N, CZERO,
+     $               WORK( INDWK2 ), N )
+         CALL CLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of CHBEVD
+*
+      END
diff --git a/SRC/chbevx.f b/SRC/chbevx.f
new file mode 100644
index 00000000..19abc5c5
--- /dev/null
+++ b/SRC/chbevx.f
@@ -0,0 +1,421 @@
+      SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
+     $                   VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AB( LDAB, * ), Q( LDQ, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian band matrix A.  Eigenvalues and eigenvectors
+*  can be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  Q       (output) COMPLEX array, dimension (LDQ, N)
+*          If JOBZ = 'V', the N-by-N unitary matrix used in the
+*                          reduction to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'V', then
+*          LDQ >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AB to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1,
+     $                   J, JJ, NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+      COMPLEX            CTMP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHB, SLAMCH
+      EXTERNAL           LSAME, CLANHB, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMV, CHBTRD, CLACPY, CLASCL, CSTEIN,
+     $                   CSTEQR, CSWAP, SCOPY, SSCAL, SSTEBZ, SSTERF,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $     INFO = -18
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         M = 1
+         IF( LOWER ) THEN
+            CTMP1 = AB( 1, 1 )
+         ELSE
+            CTMP1 = AB( KD+1, 1 )
+         END IF
+         TMP1 = REAL( CTMP1 )
+         IF( VALEIG ) THEN
+            IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
+     $         M = 0
+         END IF
+         IF( M.EQ.1 ) THEN
+            W( 1 ) = CTMP1
+            IF( WANTZ )
+     $         Z( 1, 1 ) = CONE
+         END IF
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF ( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      ENDIF
+      ANRM = CLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call CHBTRD to reduce Hermitian band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDWRK = 1
+      CALL CHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, RWORK( INDD ),
+     $             RWORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call SSTERF or CSTEQR.  If this fails for some
+*     eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL SCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL SSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL CLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL CSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL CSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by CSTEIN.
+*
+         DO 20 J = 1, M
+            CALL CCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL CGEMV( 'N', N, N, CONE, Q, LDQ, WORK, 1, CZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHBEVX
+*
+      END
diff --git a/SRC/chbgst.f b/SRC/chbgst.f
new file mode 100644
index 00000000..2ed563fb
--- /dev/null
+++ b/SRC/chbgst.f
@@ -0,0 +1,1376 @@
+      SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
+     $                   LDX, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO, VECT
+      INTEGER            INFO, KA, KB, LDAB, LDBB, LDX, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBGST reduces a complex Hermitian-definite banded generalized
+*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,
+*  such that C has the same bandwidth as A.
+*
+*  B must have been previously factorized as S**H*S by CPBSTF, using a
+*  split Cholesky factorization. A is overwritten by C = X**H*A*X, where
+*  X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the
+*  bandwidth of A.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form the transformation matrix X;
+*          = 'V':  form X.
+*
+*  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 matrices A and B.  N >= 0.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the transformed matrix X**H*A*X, stored in the same
+*          format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input) COMPLEX array, dimension (LDBB,N)
+*          The banded factor S from the split Cholesky factorization of
+*          B, as returned by CPBSTF, stored in the first kb+1 rows of
+*          the array.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  X       (output) COMPLEX array, dimension (LDX,N)
+*          If VECT = 'V', the n-by-n matrix X.
+*          If VECT = 'N', the array X is not referenced.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.
+*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CZERO, CONE
+      REAL               ONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ), ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPDATE, UPPER, WANTX
+      INTEGER            I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
+     $                   KA1, KB1, KBT, L, M, NR, NRT, NX
+      REAL               BII
+      COMPLEX            RA, RA1, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGERC, CGERU, CLACGV, CLAR2V, CLARGV, CLARTG,
+     $                   CLARTV, CLASET, CROT, CSSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTX = LSAME( VECT, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      KA1 = KA + 1
+      KB1 = KB + 1
+      INFO = 0
+      IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      INCA = LDAB*KA1
+*
+*     Initialize X to the unit matrix, if needed
+*
+      IF( WANTX )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, X, LDX )
+*
+*     Set M to the splitting point m. It must be the same value as is
+*     used in CPBSTF. The chosen value allows the arrays WORK and RWORK
+*     to be of dimension (N).
+*
+      M = ( N+KB ) / 2
+*
+*     The routine works in two phases, corresponding to the two halves
+*     of the split Cholesky factorization of B as S**H*S where
+*
+*     S = ( U    )
+*         ( M  L )
+*
+*     with U upper triangular of order m, and L lower triangular of
+*     order n-m. S has the same bandwidth as B.
+*
+*     S is treated as a product of elementary matrices:
+*
+*     S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
+*
+*     where S(i) is determined by the i-th row of S.
+*
+*     In phase 1, the index i takes the values n, n-1, ... , m+1;
+*     in phase 2, it takes the values 1, 2, ... , m.
+*
+*     For each value of i, the current matrix A is updated by forming
+*     inv(S(i))**H*A*inv(S(i)). This creates a triangular bulge outside
+*     the band of A. The bulge is then pushed down toward the bottom of
+*     A in phase 1, and up toward the top of A in phase 2, by applying
+*     plane rotations.
+*
+*     There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
+*     of them are linearly independent, so annihilating a bulge requires
+*     only 2*kb-1 plane rotations. The rotations are divided into a 1st
+*     set of kb-1 rotations, and a 2nd set of kb rotations.
+*
+*     Wherever possible, rotations are generated and applied in vector
+*     operations of length NR between the indices J1 and J2 (sometimes
+*     replaced by modified values NRT, J1T or J2T).
+*
+*     The real cosines and complex sines of the rotations are stored in
+*     the arrays RWORK and WORK, those of the 1st set in elements
+*     2:m-kb-1, and those of the 2nd set in elements m-kb+1:n.
+*
+*     The bulges are not formed explicitly; nonzero elements outside the
+*     band are created only when they are required for generating new
+*     rotations; they are stored in the array WORK, in positions where
+*     they are later overwritten by the sines of the rotations which
+*     annihilate them.
+*
+*     **************************** Phase 1 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = N, M + 1, -1
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M + KA + 1, N - 1
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = N + 1
+   10 CONTINUE
+      IF( UPDATE ) THEN
+         I = I - 1
+         KBT = MIN( KB, I-1 )
+         I0 = I - 1
+         I1 = MIN( N, I+KA )
+         I2 = I - KBT + KA1
+         IF( I.LT.M+1 ) THEN
+            UPDATE = .FALSE.
+            I = I + 1
+            I0 = M
+            IF( KA.EQ.0 )
+     $         GO TO 480
+            GO TO 10
+         END IF
+      ELSE
+         I = I + KA
+         IF( I.GT.N-1 )
+     $      GO TO 480
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = REAL( BB( KB1, I ) )
+            AB( KA1, I ) = ( REAL( AB( KA1, I ) ) / BII ) / BII
+            DO 20 J = I + 1, I1
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+   20       CONTINUE
+            DO 30 J = MAX( 1, I-KA ), I - 1
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+   30       CONTINUE
+            DO 60 K = I - KBT, I - 1
+               DO 40 J = I - KBT, K
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( J-I+KB1, I )*
+     $                               CONJG( AB( K-I+KA1, I ) ) -
+     $                               CONJG( BB( K-I+KB1, I ) )*
+     $                               AB( J-I+KA1, I ) +
+     $                               REAL( AB( KA1, I ) )*
+     $                               BB( J-I+KB1, I )*
+     $                               CONJG( BB( K-I+KB1, I ) )
+   40          CONTINUE
+               DO 50 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               CONJG( BB( K-I+KB1, I ) )*
+     $                               AB( J-I+KA1, I )
+   50          CONTINUE
+   60       CONTINUE
+            DO 80 J = I, I1
+               DO 70 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( K-I+KB1, I )*AB( I-J+KA1, J )
+   70          CONTINUE
+   80       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL CSSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL CGERC( N-M, KBT, -CONE, X( M+1, I ), 1,
+     $                        BB( KB1-KBT, I ), 1, X( M+1, I-KBT ),
+     $                        LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+KA1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 130 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i,i-k+ka+1)
+*
+                  CALL CLARTG( AB( K+1, I-K+KA ), RA1,
+     $                         RWORK( I-K+KA-M ), WORK( I-K+KA-M ), RA )
+*
+*                 create nonzero element a(i-k,i-k+ka+1) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( KB1-K, I )*RA1
+                  WORK( I-K ) = RWORK( I-K+KA-M )*T -
+     $                          CONJG( WORK( I-K+KA-M ) )*
+     $                          AB( 1, I-K+KA )
+                  AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
+     $                              RWORK( I-K+KA-M )*AB( 1, I-K+KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 90 J = J2T, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
+               AB( 1, J+1 ) = RWORK( J-M )*AB( 1, J+1 )
+   90       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL CLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
+     $                      RWORK( J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 100 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  100          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, RWORK( J2-M ),
+     $                      WORK( J2-M ), KA1 )
+*
+               CALL CLACGV( NR, WORK( J2-M ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 110 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  110       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 120 J = J2, J1, KA1
+                  CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J-M ), CONJG( WORK( J-M ) ) )
+  120          CONTINUE
+            END IF
+  130    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt,i-kbt+ka+1) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
+            END IF
+         END IF
+*
+         DO 170 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 140 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J2-L+1 ), INCA,
+     $                         AB( L+1, J2-L+1 ), INCA, RWORK( J2-KA ),
+     $                         WORK( J2-KA ), KA1 )
+  140       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 150 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               RWORK( J ) = RWORK( J-KA )
+  150       CONTINUE
+            DO 160 J = J2, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+1 )
+               AB( 1, J+1 ) = RWORK( J )*AB( 1, J+1 )
+  160       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  170    CONTINUE
+*
+         DO 210 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL CLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
+     $                      RWORK( J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 180 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  180          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, RWORK( J2 ),
+     $                      WORK( J2 ), KA1 )
+*
+               CALL CLACGV( NR, WORK( J2 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 190 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  190       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 200 J = J2, J1, KA1
+                  CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J ), CONJG( WORK( J ) ) )
+  200          CONTINUE
+            END IF
+  210    CONTINUE
+*
+         DO 230 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 220 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  220       CONTINUE
+  230    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 240 J = N - 1, I2 + KA, -1
+               RWORK( J-M ) = RWORK( J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  240       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = REAL( BB( 1, I ) )
+            AB( 1, I ) = ( REAL( AB( 1, I ) ) / BII ) / BII
+            DO 250 J = I + 1, I1
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  250       CONTINUE
+            DO 260 J = MAX( 1, I-KA ), I - 1
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  260       CONTINUE
+            DO 290 K = I - KBT, I - 1
+               DO 270 J = I - KBT, K
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( I-J+1, J )*CONJG( AB( I-K+1,
+     $                             K ) ) - CONJG( BB( I-K+1, K ) )*
+     $                             AB( I-J+1, J ) + REAL( AB( 1, I ) )*
+     $                             BB( I-J+1, J )*CONJG( BB( I-K+1,
+     $                             K ) )
+  270          CONTINUE
+               DO 280 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             CONJG( BB( I-K+1, K ) )*
+     $                             AB( I-J+1, J )
+  280          CONTINUE
+  290       CONTINUE
+            DO 310 J = I, I1
+               DO 300 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( I-K+1, K )*AB( J-I+1, I )
+  300          CONTINUE
+  310       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL CSSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL CGERU( N-M, KBT, -CONE, X( M+1, I ), 1,
+     $                        BB( KBT+1, I-KBT ), LDBB-1,
+     $                        X( M+1, I-KBT ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 360 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i-k+ka+1,i)
+*
+                  CALL CLARTG( AB( KA1-K, I ), RA1, RWORK( I-K+KA-M ),
+     $                         WORK( I-K+KA-M ), RA )
+*
+*                 create nonzero element a(i-k+ka+1,i-k) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( K+1, I-K )*RA1
+                  WORK( I-K ) = RWORK( I-K+KA-M )*T -
+     $                          CONJG( WORK( I-K+KA-M ) )*AB( KA1, I-K )
+                  AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
+     $                             RWORK( I-K+KA-M )*AB( KA1, I-K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 320 J = J2T, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = RWORK( J-M )*AB( KA1, J-KA+1 )
+  320       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL CLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
+     $                      KA1, RWORK( J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 330 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  330          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, RWORK( J2-M ), WORK( J2-M ), KA1 )
+*
+               CALL CLACGV( NR, WORK( J2-M ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 340 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  340       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 350 J = J2, J1, KA1
+                  CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J-M ), WORK( J-M ) )
+  350          CONTINUE
+            END IF
+  360    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt+ka+1,i-kbt) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
+            END IF
+         END IF
+*
+         DO 400 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 370 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
+     $                         AB( KA1-L, J2-KA+1 ), INCA,
+     $                         RWORK( J2-KA ), WORK( J2-KA ), KA1 )
+  370       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 380 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               RWORK( J ) = RWORK( J-KA )
+  380       CONTINUE
+            DO 390 J = J2, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = RWORK( J )*AB( KA1, J-KA+1 )
+  390       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  400    CONTINUE
+*
+         DO 440 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL CLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
+     $                      RWORK( J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 410 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  410          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, RWORK( J2 ), WORK( J2 ), KA1 )
+*
+               CALL CLACGV( NR, WORK( J2 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 420 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  420       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 430 J = J2, J1, KA1
+                  CALL CROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J ), WORK( J ) )
+  430          CONTINUE
+            END IF
+  440    CONTINUE
+*
+         DO 460 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 450 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  450       CONTINUE
+  460    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 470 J = N - 1, I2 + KA, -1
+               RWORK( J-M ) = RWORK( J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  470       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 10
+*
+  480 CONTINUE
+*
+*     **************************** Phase 2 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = 1, M
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M - KA - 1, 2, -1
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = 0
+  490 CONTINUE
+      IF( UPDATE ) THEN
+         I = I + 1
+         KBT = MIN( KB, M-I )
+         I0 = I + 1
+         I1 = MAX( 1, I-KA )
+         I2 = I + KBT - KA1
+         IF( I.GT.M ) THEN
+            UPDATE = .FALSE.
+            I = I - 1
+            I0 = M + 1
+            IF( KA.EQ.0 )
+     $         RETURN
+            GO TO 490
+         END IF
+      ELSE
+         I = I - KA
+         IF( I.LT.2 )
+     $      RETURN
+      END IF
+*
+      IF( I.LT.M-KBT ) THEN
+         NX = M
+      ELSE
+         NX = N
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = REAL( BB( KB1, I ) )
+            AB( KA1, I ) = ( REAL( AB( KA1, I ) ) / BII ) / BII
+            DO 500 J = I1, I - 1
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+  500       CONTINUE
+            DO 510 J = I + 1, MIN( N, I+KA )
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+  510       CONTINUE
+            DO 540 K = I + 1, I + KBT
+               DO 520 J = K, I + KBT
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( I-J+KB1, J )*
+     $                               CONJG( AB( I-K+KA1, K ) ) -
+     $                               CONJG( BB( I-K+KB1, K ) )*
+     $                               AB( I-J+KA1, J ) +
+     $                               REAL( AB( KA1, I ) )*
+     $                               BB( I-J+KB1, J )*
+     $                               CONJG( BB( I-K+KB1, K ) )
+  520          CONTINUE
+               DO 530 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               CONJG( BB( I-K+KB1, K ) )*
+     $                               AB( I-J+KA1, J )
+  530          CONTINUE
+  540       CONTINUE
+            DO 560 J = I1, I
+               DO 550 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( I-K+KB1, K )*AB( J-I+KA1, I )
+  550          CONTINUE
+  560       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL CSSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL CGERU( NX, KBT, -CONE, X( 1, I ), 1,
+     $                        BB( KB, I+1 ), LDBB-1, X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+KA1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 610 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i+k-ka-1,i)
+*
+                  CALL CLARTG( AB( K+1, I ), RA1, RWORK( I+K-KA ),
+     $                         WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k-ka-1,i+k) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( KB1-K, I+K )*RA1
+                  WORK( M-KB+I+K ) = RWORK( I+K-KA )*T -
+     $                               CONJG( WORK( I+K-KA ) )*
+     $                               AB( 1, I+K )
+                  AB( 1, I+K ) = WORK( I+K-KA )*T +
+     $                           RWORK( I+K-KA )*AB( 1, I+K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 570 J = J1, J2T, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = RWORK( J )*AB( 1, J+KA-1 )
+  570       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL CLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
+     $                      RWORK( J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 580 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA, RWORK( J1 ),
+     $                         WORK( J1 ), KA1 )
+  580          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, RWORK( J1 ), WORK( J1 ),
+     $                      KA1 )
+*
+               CALL CLACGV( NR, WORK( J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 590 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, RWORK( J1T ),
+     $                         WORK( J1T ), KA1 )
+  590       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 600 J = J1, J2, KA1
+                  CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( J ), WORK( J ) )
+  600          CONTINUE
+            END IF
+  610    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt-ka-1,i+kbt) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
+            END IF
+         END IF
+*
+         DO 650 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 620 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J1T+KA ), INCA,
+     $                         AB( L+1, J1T+KA-1 ), INCA,
+     $                         RWORK( M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  620       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 630 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               RWORK( M-KB+J ) = RWORK( M-KB+J+KA )
+  630       CONTINUE
+            DO 640 J = J1, J2, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = RWORK( M-KB+J )*AB( 1, J+KA-1 )
+  640       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  650    CONTINUE
+*
+         DO 690 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL CLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, RWORK( M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 660 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA, RWORK( M-KB+J1 ),
+     $                         WORK( M-KB+J1 ), KA1 )
+  660          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, RWORK( M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+               CALL CLACGV( NR, WORK( M-KB+J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 670 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA,
+     $                         RWORK( M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  670       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 680 J = J1, J2, KA1
+                  CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( M-KB+J ), WORK( M-KB+J ) )
+  680          CONTINUE
+            END IF
+  690    CONTINUE
+*
+         DO 710 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 700 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, RWORK( J1T ),
+     $                         WORK( J1T ), KA1 )
+  700       CONTINUE
+  710    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 720 J = 2, I2 - KA
+               RWORK( J ) = RWORK( J+KA )
+               WORK( J ) = WORK( J+KA )
+  720       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = REAL( BB( 1, I ) )
+            AB( 1, I ) = ( REAL( AB( 1, I ) ) / BII ) / BII
+            DO 730 J = I1, I - 1
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  730       CONTINUE
+            DO 740 J = I + 1, MIN( N, I+KA )
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  740       CONTINUE
+            DO 770 K = I + 1, I + KBT
+               DO 750 J = K, I + KBT
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( J-I+1, I )*CONJG( AB( K-I+1,
+     $                             I ) ) - CONJG( BB( K-I+1, I ) )*
+     $                             AB( J-I+1, I ) + REAL( AB( 1, I ) )*
+     $                             BB( J-I+1, I )*CONJG( BB( K-I+1,
+     $                             I ) )
+  750          CONTINUE
+               DO 760 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             CONJG( BB( K-I+1, I ) )*
+     $                             AB( J-I+1, I )
+  760          CONTINUE
+  770       CONTINUE
+            DO 790 J = I1, I
+               DO 780 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( K-I+1, I )*AB( I-J+1, J )
+  780          CONTINUE
+  790       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL CSSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL CGERC( NX, KBT, -CONE, X( 1, I ), 1, BB( 2, I ),
+     $                        1, X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 840 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i,i+k-ka-1)
+*
+                  CALL CLARTG( AB( KA1-K, I+K-KA ), RA1,
+     $                         RWORK( I+K-KA ), WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k,i+k-ka-1) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( K+1, I )*RA1
+                  WORK( M-KB+I+K ) = RWORK( I+K-KA )*T -
+     $                               CONJG( WORK( I+K-KA ) )*
+     $                               AB( KA1, I+K-KA )
+                  AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
+     $                                RWORK( I+K-KA )*AB( KA1, I+K-KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 800 J = J1, J2T, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = RWORK( J )*AB( KA1, J-1 )
+  800       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL CLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
+     $                      RWORK( J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 810 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, RWORK( J1 ), WORK( J1 ), KA1 )
+  810          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, RWORK( J1 ),
+     $                      WORK( J1 ), KA1 )
+*
+               CALL CLACGV( NR, WORK( J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 820 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         RWORK( J1T ), WORK( J1T ), KA1 )
+  820       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 830 J = J1, J2, KA1
+                  CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( J ), CONJG( WORK( J ) ) )
+  830          CONTINUE
+            END IF
+  840    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt,i+kbt-ka-1) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
+            END IF
+         END IF
+*
+         DO 880 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 850 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
+     $                         AB( KA1-L, J1T+L-1 ), INCA,
+     $                         RWORK( M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  850       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 860 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               RWORK( M-KB+J ) = RWORK( M-KB+J+KA )
+  860       CONTINUE
+            DO 870 J = J1, J2, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = RWORK( M-KB+J )*AB( KA1, J-1 )
+  870       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  880    CONTINUE
+*
+         DO 920 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL CLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, RWORK( M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 890 L = 1, KA - 1
+                  CALL CLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, RWORK( M-KB+J1 ), WORK( M-KB+J1 ),
+     $                         KA1 )
+  890          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL CLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, RWORK( M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+               CALL CLACGV( NR, WORK( M-KB+J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 900 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         RWORK( M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  900       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 910 J = J1, J2, KA1
+                  CALL CROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( M-KB+J ), CONJG( WORK( M-KB+J ) ) )
+  910          CONTINUE
+            END IF
+  920    CONTINUE
+*
+         DO 940 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 930 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL CLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         RWORK( J1T ), WORK( J1T ), KA1 )
+  930       CONTINUE
+  940    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 950 J = 2, I2 - KA
+               RWORK( J ) = RWORK( J+KA )
+               WORK( J ) = WORK( J+KA )
+  950       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 490
+*
+*     End of CHBGST
+*
+      END
diff --git a/SRC/chbgv.f b/SRC/chbgv.f
new file mode 100644
index 00000000..0230cda9
--- /dev/null
+++ b/SRC/chbgv.f
@@ -0,0 +1,191 @@
+      SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
+     $                  LDZ, WORK, 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, KA, KB, LDAB, LDBB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
+*  and banded, and B is also positive definite.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) COMPLEX array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**H*S, as returned by CPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**H*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 >= N.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL 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, and i is:
+*             <= N:  the algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF
+*                    returned INFO = i: 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          VECT
+      INTEGER            IINFO, INDE, INDWRK
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHBGST, CHBTRD, CPBSTF, CSTEQR, SSTERF, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL CPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      CALL CHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK, RWORK( INDWRK ), IINFO )
+*
+*     Reduce to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL CHBTRD( VECT, UPLO, N, KA, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call CSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL CSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
+     $                RWORK( INDWRK ), INFO )
+      END IF
+      RETURN
+*
+*     End of CHBGV
+*
+      END
diff --git a/SRC/chbgvd.f b/SRC/chbgvd.f
new file mode 100644
index 00000000..f93ed18d
--- /dev/null
+++ b/SRC/chbgvd.f
@@ -0,0 +1,297 @@
+      SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
+     $                   Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK,
+     $                   LIWORK, 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, KA, KB, LDAB, LDBB, LDZ, LIWORK, LRWORK,
+     $                   LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
+*  and banded, and B is also positive definite.  If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) COMPLEX array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**H*S, as returned by CPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**H*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 >= N.
+*
+*  WORK    (workspace/output) COMPLEX 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 N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LRWORK >= N.
+*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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 array IWORK.
+*          If JOBZ = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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, and i is:
+*             <= N:  the algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CONE, CZERO
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          VECT
+      INTEGER            IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLRWK,
+     $                   LLWK2, LRWMIN, LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CHBGST, CHBTRD, CLACPY, CPBSTF, CSTEDC,
+     $                   SSTERF, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LWMIN = 1
+         LRWMIN = 1
+         LIWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LWMIN = 2*N**2
+         LRWMIN = 1 + 5*N + 2*N**2
+         LIWMIN = 3 + 5*N
+      ELSE
+         LWMIN = N
+         LRWMIN = N
+         LIWMIN = 1
+      END IF
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -14
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -16
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL CPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = 1 + N*N
+      LLWK2 = LWORK - INDWK2 + 2
+      LLRWK = LRWORK - INDWRK + 2
+      CALL CHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK, RWORK( INDWRK ), IINFO )
+*
+*     Reduce Hermitian band matrix to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL CHBTRD( VECT, UPLO, N, KA, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call CSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL CSTEDC( 'I', N, W, RWORK( INDE ), WORK, N, WORK( INDWK2 ),
+     $                LLWK2, RWORK( INDWRK ), LLRWK, IWORK, LIWORK,
+     $                INFO )
+         CALL CGEMM( 'N', 'N', N, N, N, CONE, Z, LDZ, WORK, N, CZERO,
+     $               WORK( INDWK2 ), N )
+         CALL CLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of CHBGVD
+*
+      END
diff --git a/SRC/chbgvx.f b/SRC/chbgvx.f
new file mode 100644
index 00000000..5e6ab664
--- /dev/null
+++ b/SRC/chbgvx.f
@@ -0,0 +1,390 @@
+      SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB,
+     $                   LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z,
+     $                   LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
+     $                   N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBGVX computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
+*  and banded, and B is also positive definite.  Eigenvalues and
+*  eigenvectors can be selected by specifying either all eigenvalues,
+*  a range of values or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) COMPLEX array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**H*S, as returned by CPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  Q       (output) COMPLEX array, dimension (LDQ, N)
+*          If JOBZ = 'V', the n-by-n matrix used in the reduction of
+*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
+*          and consequently C to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'N',
+*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**H*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 >= N.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  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:  then i eigenvectors failed to converge.  Their
+*                    indices are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
+      CHARACTER          ORDER, VECT
+      INTEGER            I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
+     $                   INDIWK, INDRWK, INDWRK, ITMP1, J, JJ, NSPLIT
+      REAL               TMP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMV, CHBGST, CHBTRD, CLACPY, CPBSTF,
+     $                   CSTEIN, CSTEQR, CSWAP, SCOPY, SSTEBZ, SSTERF,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -8
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -10
+      ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
+         INFO = -12
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -14
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -15
+            ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -16
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -21
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL CPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      CALL CHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
+     $             WORK, RWORK, IINFO )
+*
+*     Solve the standard eigenvalue problem.
+*     Reduce Hermitian band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDWRK = 1
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL CHBTRD( VECT, UPLO, N, KA, AB, LDAB, RWORK( INDD ),
+     $             RWORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call SSTERF or CSTEQR.  If this fails for some
+*     eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL SCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+         IF( .NOT.WANTZ ) THEN
+            CALL SSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL CLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL CSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired,
+*     call CSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL CSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by CSTEIN.
+*
+         DO 20 J = 1, M
+            CALL CCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL CGEMV( 'N', N, N, CONE, Q, LDQ, WORK, 1, CZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+   30 CONTINUE
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHBGVX
+*
+      END
diff --git a/SRC/chbtrd.f b/SRC/chbtrd.f
new file mode 100644
index 00000000..cff1efeb
--- /dev/null
+++ b/SRC/chbtrd.f
@@ -0,0 +1,588 @@
+      SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, 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, VECT
+      INTEGER            INFO, KD, LDAB, LDQ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E( * )
+      COMPLEX            AB( LDAB, * ), Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHBTRD reduces a complex Hermitian band matrix A to real symmetric
+*  tridiagonal form T by a unitary similarity transformation:
+*  Q**H * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form Q;
+*          = 'V':  form Q;
+*          = 'U':  update a matrix X, by forming X*Q.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          On exit, the diagonal elements of AB are overwritten by the
+*          diagonal elements of the tridiagonal matrix T; if KD > 0, the
+*          elements on the first superdiagonal (if UPLO = 'U') or the
+*          first subdiagonal (if UPLO = 'L') are overwritten by the
+*          off-diagonal elements of T; the rest of AB is overwritten by
+*          values generated during the reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  D       (output) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T.
+*
+*  E       (output) REAL array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
+*
+*  Q       (input/output) COMPLEX array, dimension (LDQ,N)
+*          On entry, if VECT = 'U', then Q must contain an N-by-N
+*          matrix X; if VECT = 'N' or 'V', then Q need not be set.
+*
+*          On exit:
+*          if VECT = 'V', Q contains the N-by-N unitary matrix Q;
+*          if VECT = 'U', Q contains the product X*Q;
+*          if VECT = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Modified by Linda Kaufman, Bell Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            INITQ, UPPER, WANTQ
+      INTEGER            I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
+     $                   J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
+     $                   KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
+      REAL               ABST
+      COMPLEX            T, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLAR2V, CLARGV, CLARTG, CLARTV, CLASET,
+     $                   CROT, CSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, MIN, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INITQ = LSAME( VECT, 'V' )
+      WANTQ = INITQ .OR. LSAME( VECT, 'U' )
+      UPPER = LSAME( UPLO, 'U' )
+      KD1 = KD + 1
+      KDM1 = KD - 1
+      INCX = LDAB - 1
+      IQEND = 1
+*
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD1 ) THEN
+         INFO = -6
+      ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHBTRD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize Q to the unit matrix, if needed
+*
+      IF( INITQ )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+*
+*     Wherever possible, plane rotations are generated and applied in
+*     vector operations of length NR over the index set J1:J2:KD1.
+*
+*     The real cosines and complex sines of the plane rotations are
+*     stored in the arrays D and WORK.
+*
+      INCA = KD1*LDAB
+      KDN = MIN( N-1, KD )
+      IF( UPPER ) THEN
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to complex Hermitian tridiagonal form, working with
+*           the upper triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            AB( KD1, 1 ) = REAL( AB( KD1, 1 ) )
+            DO 90 I = 1, N - 2
+*
+*              Reduce i-th row of matrix to tridiagonal form
+*
+               DO 80 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL CLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
+     $                            KD1, D( J1 ), KD1 )
+*
+*                    apply rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    CLARTV or CROT is used
+*
+                     IF( NR.GE.2*KD-1 ) THEN
+                        DO 10 L = 1, KD - 1
+                           CALL CLARTV( NR, AB( L+1, J1-1 ), INCA,
+     $                                  AB( L, J1 ), INCA, D( J1 ),
+     $                                  WORK( J1 ), KD1 )
+   10                   CONTINUE
+*
+                     ELSE
+                        JEND = J1 + ( NR-1 )*KD1
+                        DO 20 JINC = J1, JEND, KD1
+                           CALL CROT( KDM1, AB( 2, JINC-1 ), 1,
+     $                                AB( 1, JINC ), 1, D( JINC ),
+     $                                WORK( JINC ) )
+   20                   CONTINUE
+                     END IF
+                  END IF
+*
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i,i+k-1)
+*                       within the band
+*
+                        CALL CLARTG( AB( KD-K+3, I+K-2 ),
+     $                               AB( KD-K+2, I+K-1 ), D( I+K-1 ),
+     $                               WORK( I+K-1 ), TEMP )
+                        AB( KD-K+3, I+K-2 ) = TEMP
+*
+*                       apply rotation from the right
+*
+                        CALL CROT( K-3, AB( KD-K+4, I+K-2 ), 1,
+     $                             AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL CLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
+     $                            AB( KD, J1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the left
+*
+                  IF( NR.GT.0 ) THEN
+                     CALL CLACGV( NR, WORK( J1 ), KD1 )
+                     IF( 2*KD-1.LT.NR ) THEN
+*
+*                    Dependent on the the number of diagonals either
+*                    CLARTV or CROT is used
+*
+                        DO 30 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL CLARTV( NRT, AB( KD-L, J1+L ), INCA,
+     $                                     AB( KD-L+1, J1+L ), INCA,
+     $                                     D( J1 ), WORK( J1 ), KD1 )
+   30                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 40 JIN = J1, J1END, KD1
+                              CALL CROT( KD-1, AB( KD-1, JIN+1 ), INCX,
+     $                                   AB( KD, JIN+1 ), INCX,
+     $                                   D( JIN ), WORK( JIN ) )
+   40                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL CROT( LEND, AB( KD-1, LAST+1 ), INCX,
+     $                                AB( KD, LAST+1 ), INCX, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 50 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL CROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), CONJG( WORK( J ) ) )
+   50                   CONTINUE
+                     ELSE
+*
+                        DO 60 J = J1, J2, KD1
+                           CALL CROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), CONJG( WORK( J ) ) )
+   60                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 70 J = J1, J2, KD1
+*
+*                    create nonzero element a(j-1,j+kd) outside the band
+*                    and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
+                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
+   70             CONTINUE
+   80          CONTINUE
+   90       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           make off-diagonal elements real and copy them to E
+*
+            DO 100 I = 1, N - 1
+               T = AB( KD, I+1 )
+               ABST = ABS( T )
+               AB( KD, I+1 ) = ABST
+               E( I ) = ABST
+               IF( ABST.NE.ZERO ) THEN
+                  T = T / ABST
+               ELSE
+                  T = CONE
+               END IF
+               IF( I.LT.N-1 )
+     $            AB( KD, I+2 ) = AB( KD, I+2 )*T
+               IF( WANTQ ) THEN
+                  CALL CSCAL( N, CONJG( T ), Q( 1, I+1 ), 1 )
+               END IF
+  100       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 110 I = 1, N - 1
+               E( I ) = ZERO
+  110       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 120 I = 1, N
+            D( I ) = AB( KD1, I )
+  120    CONTINUE
+*
+      ELSE
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to complex Hermitian tridiagonal form, working with
+*           the lower triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            AB( 1, 1 ) = REAL( AB( 1, 1 ) )
+            DO 210 I = 1, N - 2
+*
+*              Reduce i-th column of matrix to tridiagonal form
+*
+               DO 200 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL CLARGV( NR, AB( KD1, J1-KD1 ), INCA,
+     $                            WORK( J1 ), KD1, D( J1 ), KD1 )
+*
+*                    apply plane rotations from one side
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    CLARTV or CROT is used
+*
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 130 L = 1, KD - 1
+                           CALL CLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
+     $                                  AB( KD1-L+1, J1-KD1+L ), INCA,
+     $                                  D( J1 ), WORK( J1 ), KD1 )
+  130                   CONTINUE
+                     ELSE
+                        JEND = J1 + KD1*( NR-1 )
+                        DO 140 JINC = J1, JEND, KD1
+                           CALL CROT( KDM1, AB( KD, JINC-KD ), INCX,
+     $                                AB( KD1, JINC-KD ), INCX,
+     $                                D( JINC ), WORK( JINC ) )
+  140                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i+k-1,i)
+*                       within the band
+*
+                        CALL CLARTG( AB( K-1, I ), AB( K, I ),
+     $                               D( I+K-1 ), WORK( I+K-1 ), TEMP )
+                        AB( K-1, I ) = TEMP
+*
+*                       apply rotation from the left
+*
+                        CALL CROT( K-3, AB( K-2, I+1 ), LDAB-1,
+     $                             AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL CLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
+     $                            AB( 2, J1-1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    CLARTV or CROT is used
+*
+                  IF( NR.GT.0 ) THEN
+                     CALL CLACGV( NR, WORK( J1 ), KD1 )
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 150 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL CLARTV( NRT, AB( L+2, J1-1 ), INCA,
+     $                                     AB( L+1, J1 ), INCA, D( J1 ),
+     $                                     WORK( J1 ), KD1 )
+  150                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 160 J1INC = J1, J1END, KD1
+                              CALL CROT( KDM1, AB( 3, J1INC-1 ), 1,
+     $                                   AB( 2, J1INC ), 1, D( J1INC ),
+     $                                   WORK( J1INC ) )
+  160                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL CROT( LEND, AB( 3, LAST-1 ), 1,
+     $                                AB( 2, LAST ), 1, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+*
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 170 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL CROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), WORK( J ) )
+  170                   CONTINUE
+                     ELSE
+*
+                        DO 180 J = J1, J2, KD1
+                           CALL CROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), WORK( J ) )
+  180                   CONTINUE
+                     END IF
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 190 J = J1, J2, KD1
+*
+*                    create nonzero element a(j+kd,j-1) outside the
+*                    band and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( KD1, J )
+                     AB( KD1, J ) = D( J )*AB( KD1, J )
+  190             CONTINUE
+  200          CONTINUE
+  210       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           make off-diagonal elements real and copy them to E
+*
+            DO 220 I = 1, N - 1
+               T = AB( 2, I )
+               ABST = ABS( T )
+               AB( 2, I ) = ABST
+               E( I ) = ABST
+               IF( ABST.NE.ZERO ) THEN
+                  T = T / ABST
+               ELSE
+                  T = CONE
+               END IF
+               IF( I.LT.N-1 )
+     $            AB( 2, I+1 ) = AB( 2, I+1 )*T
+               IF( WANTQ ) THEN
+                  CALL CSCAL( N, T, Q( 1, I+1 ), 1 )
+               END IF
+  220       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 230 I = 1, N - 1
+               E( I ) = ZERO
+  230       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 240 I = 1, N
+            D( I ) = AB( 1, I )
+  240    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHBTRD
+*
+      END
diff --git a/SRC/checon.f b/SRC/checon.f
new file mode 100644
index 00000000..0a422ccc
--- /dev/null
+++ b/SRC/checon.f
@@ -0,0 +1,163 @@
+      SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHECON estimates the reciprocal of the condition number of a complex
+*  Hermitian matrix A using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by CHETRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CHETRF.
+*
+*  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 CHETRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, KASE
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHETRS, CLACN2, 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( 'CHECON', -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 CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL CHETRS( 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 CHECON
+*
+      END
diff --git a/SRC/cheev.f b/SRC/cheev.f
new file mode 100644
index 00000000..78fa34d7
--- /dev/null
+++ b/SRC/cheev.f
@@ -0,0 +1,218 @@
+      SUBROUTINE CHEEV( 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 ..
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEEV 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 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) COMPLEX 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 CHETRD 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
+     $                   LLWORK, LWKOPT, NB
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANHE, SLAMCH
+      EXTERNAL           ILAENV, LSAME, CLANHE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHETRD, CLASCL, CSTEQR, CUNGTR, SSCAL, SSTERF,
+     $                   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, 'CHETRD', 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( 'CHEEV ', -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 = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = CLANHE( '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 CLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call CHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL CHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     CUNGTR to generate the unitary matrix, then call CSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL CUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
+     $                LLWORK, IINFO )
+         INDWRK = INDE + N
+         CALL CSTEQR( 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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     Set WORK(1) to optimal complex workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CHEEV
+*
+      END
diff --git a/SRC/cheevd.f b/SRC/cheevd.f
new file mode 100644
index 00000000..79490a6e
--- /dev/null
+++ b/SRC/cheevd.f
@@ -0,0 +1,305 @@
+      SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
+     $                   LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEEVD computes all eigenvalues and, optionally, eigenvectors of a
+*  complex Hermitian matrix A.  If eigenvectors are desired, it uses a
+*  divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) COMPLEX 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.
+*          If N <= 1,                LWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LWORK must be at least N + 1.
+*          If JOBZ  = 'V' and N > 1, LWORK must be at least 2*N + N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array,
+*                                         dimension (LRWORK)
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of the array RWORK.
+*          If N <= 1,                LRWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LRWORK must be at least N.
+*          If JOBZ  = 'V' and N > 1, LRWORK must be at least
+*                         1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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.
+*          If N <= 1,                LIWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed
+*                to converge; i off-diagonal elements of an intermediate
+*                tridiagonal form did not converge to zero;
+*                if INFO = i and JOBZ = 'V', then the algorithm failed
+*                to compute an eigenvalue while working on the submatrix
+*                lying in rows and columns INFO/(N+1) through
+*                mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  Modified description of INFO. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2,
+     $                   INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
+     $                   LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANHE, SLAMCH
+      EXTERNAL           ILAENV, LSAME, CLANHE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHETRD, CLACPY, CLASCL, CSTEDC, CUNMTR, SSCAL,
+     $                   SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+            LRWMIN = 1
+            LIWMIN = 1
+            LOPT = LWMIN
+            LROPT = LRWMIN
+            LIOPT = LIWMIN
+         ELSE
+            IF( WANTZ ) THEN
+               LWMIN = 2*N + N*N
+               LRWMIN = 1 + 5*N + 2*N**2
+               LIWMIN = 3 + 5*N
+            ELSE
+               LWMIN = N + 1
+               LRWMIN = N
+               LIWMIN = 1
+            END IF
+            LOPT = MAX( LWMIN, N +
+     $                  ILAENV( 1, 'CHETRD', UPLO, N, -1, -1, -1 ) )
+            LROPT = LRWMIN
+            LIOPT = LIWMIN
+         END IF
+         WORK( 1 ) = LOPT
+         RWORK( 1 ) = LROPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEEVD', -INFO )
+         RETURN 
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = A( 1, 1 )
+         IF( WANTZ )
+     $      A( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = CLANHE( '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 CLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call CHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      INDRWK = INDE + N
+      INDWK2 = INDWRK + N*N
+      LLWORK = LWORK - INDWRK + 1
+      LLWRK2 = LWORK - INDWK2 + 1
+      LLRWK = LRWORK - INDRWK + 1
+      CALL CHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     CSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+*     tridiagonal matrix, then call CUNMTR to multiply it to the
+*     Householder transformations represented as Householder vectors in
+*     A.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL CSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
+     $                IWORK, LIWORK, INFO )
+         CALL CUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
+     $                WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
+         CALL CLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
+      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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      WORK( 1 ) = LOPT
+      RWORK( 1 ) = LROPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of CHEEVD
+*
+      END
diff --git a/SRC/cheevr.f b/SRC/cheevr.f
new file mode 100644
index 00000000..6e63948b
--- /dev/null
+++ b/SRC/cheevr.f
@@ -0,0 +1,588 @@
+      SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
+     $                   RWORK, LRWORK, IWORK, LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
+     $                   M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEEVR computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can
+*  be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  CHEEVR first reduces the matrix A to tridiagonal form T with a call
+*  to CHETRD.  Then, whenever possible, CHEEVR calls CSTEMR to compute
+*  the eigenspectrum using Relatively Robust Representations.  CSTEMR
+*  computes eigenvalues by the dqds algorithm, while orthogonal
+*  eigenvectors are computed from various "good" L D L^T representations
+*  (also known as Relatively Robust Representations). Gram-Schmidt
+*  orthogonalization is avoided as far as possible. More specifically,
+*  the various steps of the algorithm are as follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  The desired accuracy of the output can be specified by the input
+*  parameter ABSTOL.
+*
+*  For more details, see DSTEMR's documentation and:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*
+*  Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested
+*  on machines which conform to the ieee-754 floating point standard.
+*  CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and
+*  when partial spectrum requests are made.
+*
+*  Normal execution of CSTEMR may create NaNs and infinities and
+*  hence may abort due to a floating point exception in environments
+*  which do not handle NaNs and infinities in the ieee standard default
+*  manner.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
+********** CSTEIN are called
+*
+*  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 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, 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).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*          If high relative accuracy is important, set ABSTOL to
+*          SLAMCH( 'Safe minimum' ).  Doing so will guarantee that
+*          eigenvalues are computed to high relative accuracy when
+*          possible in future releases.  The current code does not
+*          make any guarantees about high relative accuracy, but
+*          furutre releases will. See J. Barlow and J. Demmel,
+*          "Computing Accurate Eigensystems of Scaled Diagonally
+*          Dominant Matrices", LAPACK Working Note #7, for a discussion
+*          of which matrices define their eigenvalues to high relative
+*          accuracy.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+*  WORK    (workspace/output) COMPLEX 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).
+*          For optimal efficiency, LWORK >= (NB+1)*N,
+*          where NB is the max of the blocksize for CHETRD and for
+*          CUNMTR as returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the optimal
+*          (and minimal) LRWORK.
+*
+* LRWORK   (input) INTEGER
+*          The length of the array RWORK.  LRWORK >= max(1,24*N).
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal
+*          (and minimal) LIWORK.
+*
+* LIWORK   (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  Internal error
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Ken Stanley, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Jason Riedy, Computer Science Division, University of
+*       California at Berkeley, USA
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ, TRYRAC
+      CHARACTER          ORDER
+      INTEGER            I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
+     $                   INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK,
+     $                   INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ,
+     $                   LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN,
+     $                   LWKOPT, LWMIN, NB, NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANSY, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANSY, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHETRD, CSSCAL, CSTEMR, CSTEIN, CSWAP, CUNMTR,
+     $                   SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      IEEEOK = ILAENV( 10, 'CHEEVR', 'N', 1, 2, 3, 4 )
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR.
+     $         ( LIWORK.EQ.-1 ) )
+*
+      LRWMIN = MAX( 1, 24*N )
+      LIWMIN = MAX( 1, 10*N )
+      LWMIN = MAX( 1, 2*N )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'CHETRD', UPLO, N, -1, -1, -1 )
+         NB = MAX( NB, ILAENV( 1, 'CUNMTR', UPLO, N, -1, -1, -1 ) )
+         LWKOPT = MAX( ( NB+1 )*N, LWMIN )
+         WORK( 1 ) = LWKOPT
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -22
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEEVR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         WORK( 1 ) = 2
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = REAL( A( 1, 1 ) )
+         ELSE
+            IF( VL.LT.REAL( A( 1, 1 ) ) .AND. VU.GE.REAL( A( 1, 1 ) ) )
+     $           THEN
+               M = 1
+               W( 1 ) = REAL( A( 1, 1 ) )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF (VALEIG) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = CLANSY( 'M', UPLO, N, A, LDA, RWORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL CSSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL CSSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+
+*     Initialize indices into workspaces.  Note: The IWORK indices are
+*     used only if SSTERF or CSTEMR fail.
+
+*     WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the
+*     elementary reflectors used in CHETRD.
+      INDTAU = 1
+*     INDWK is the starting offset of the remaining complex workspace,
+*     and LLWORK is the remaining complex workspace size.
+      INDWK = INDTAU + N
+      LLWORK = LWORK - INDWK + 1
+
+*     RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal
+*     entries.
+      INDRD = 1
+*     RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the
+*     tridiagonal matrix from CHETRD.
+      INDRE = INDRD + N
+*     RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over
+*     -written by CSTEMR (the SSTERF path copies the diagonal to W).
+      INDRDD = INDRE + N
+*     RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over
+*     -written while computing the eigenvalues in SSTERF and CSTEMR.
+      INDREE = INDRDD + N
+*     INDRWK is the starting offset of the left-over real workspace, and
+*     LLRWORK is the remaining workspace size.
+      INDRWK = INDREE + N
+      LLRWORK = LRWORK - INDRWK + 1
+
+*     IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
+*     stores the block indices of each of the M<=N eigenvalues.
+      INDIBL = 1
+*     IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
+*     stores the starting and finishing indices of each block.
+      INDISP = INDIBL + N
+*     IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+*     that corresponding to eigenvectors that fail to converge in
+*     SSTEIN.  This information is discarded; if any fail, the driver
+*     returns INFO > 0.
+      INDIFL = INDISP + N
+*     INDIWO is the offset of the remaining integer workspace.
+      INDIWO = INDISP + N
+
+*
+*     Call CHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      CALL CHETRD( UPLO, N, A, LDA, RWORK( INDRD ), RWORK( INDRE ),
+     $             WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired
+*     then call SSTERF or CSTEMR and CUNMTR.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N, RWORK( INDRD ), 1, W, 1 )
+            CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 )
+            CALL SSTERF( N, W, RWORK( INDREE ), INFO )
+         ELSE
+            CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 )
+            CALL SCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 )
+*
+            IF (ABSTOL .LE. TWO*N*EPS) THEN
+               TRYRAC = .TRUE.
+            ELSE
+               TRYRAC = .FALSE.
+            END IF
+            CALL CSTEMR( JOBZ, 'A', N, RWORK( INDRDD ),
+     $                   RWORK( INDREE ), VL, VU, IL, IU, M, W,
+     $                   Z, LDZ, N, ISUPPZ, TRYRAC,
+     $                   RWORK( INDRWK ), LLRWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*           Apply unitary matrix used in reduction to tridiagonal
+*           form to eigenvectors returned by CSTEIN.
+*
+            IF( WANTZ .AND. INFO.EQ.0 ) THEN
+               INDWKN = INDWK
+               LLWRKN = LWORK - INDWKN + 1
+               CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA,
+     $                      WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
+     $                      LLWRKN, IINFO )
+            END IF
+         END IF
+*
+*
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN.
+*     Also call SSTEBZ and CSTEIN if CSTEMR fails.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL CSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ),
+     $                INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by CSTEIN.
+*
+         INDWKN = INDWK
+         LLWRKN = LWORK - INDWKN + 1
+         CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+            END IF
+   50    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of CHEEVR
+*
+      END
diff --git a/SRC/cheevx.f b/SRC/cheevx.f
new file mode 100644
index 00000000..a484ead4
--- /dev/null
+++ b/SRC/cheevx.f
@@ -0,0 +1,439 @@
+      SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LWORK, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can
+*  be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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 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, 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).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) COMPLEX 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 >= 1, when N <= 1;
+*          otherwise 2*N.
+*          For optimal efficiency, LWORK >= (NB+1)*N,
+*          where NB is the max of the blocksize for CHETRD and for
+*          CUNMTR as 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) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
+     $                   ITMP1, J, JJ, LLWORK, LWKMIN, LWKOPT, NB,
+     $                   NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANHE, SLAMCH
+      EXTERNAL           LSAME, ILAENV, CLANHE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHETRD, CLACPY, CSSCAL, CSTEIN, CSTEQR, CSWAP,
+     $                   CUNGTR, CUNMTR, SCOPY, SSCAL, SSTEBZ, SSTERF,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWKMIN = 1
+            WORK( 1 ) = LWKMIN
+         ELSE
+            LWKMIN = 2*N
+            NB = ILAENV( 1, 'CHETRD', UPLO, N, -1, -1, -1 )
+            NB = MAX( NB, ILAENV( 1, 'CUNMTR', UPLO, N, -1, -1, -1 ) )
+            LWKOPT = MAX( 1, ( NB + 1 )*N )
+            WORK( 1 ) = LWKOPT
+         END IF
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+     $      INFO = -17
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = A( 1, 1 )
+         ELSE IF( VALEIG ) THEN
+            IF( VL.LT.REAL( A( 1, 1 ) ) .AND. VU.GE.REAL( A( 1, 1 ) ) )
+     $           THEN
+               M = 1
+               W( 1 ) = A( 1, 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = CLANHE( 'M', UPLO, N, A, LDA, RWORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL CSSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL CSSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call CHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL CHETRD( UPLO, N, A, LDA, RWORK( INDD ), RWORK( INDE ),
+     $             WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal to
+*     zero, then call SSTERF or CUNGTR and CSTEQR.  If this fails for
+*     some eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL SCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL SSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL CLACPY( 'A', N, N, A, LDA, Z, LDZ )
+            CALL CUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
+     $                   WORK( INDWRK ), LLWORK, IINFO )
+            CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL CSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 30 I = 1, N
+                  IFAIL( I ) = 0
+   30          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 40
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL CSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by CSTEIN.
+*
+         CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWRK ), LLWORK, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   40 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 60 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 50 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   50       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   60    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal complex workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CHEEVX
+*
+      END
diff --git a/SRC/chegs2.f b/SRC/chegs2.f
new file mode 100644
index 00000000..5bc7869c
--- /dev/null
+++ b/SRC/chegs2.f
@@ -0,0 +1,224 @@
+      SUBROUTINE CHEGS2( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEGS2 reduces a complex Hermitian-definite generalized
+*  eigenproblem to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
+*
+*  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` or L'*A*L.
+*
+*  B must have been previously factorized as U'*U or L*L' by CPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
+*          = 2 or 3: compute U*A*U' or L'*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          Hermitian matrix A is stored, and how B has been factorized.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) COMPLEX 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 transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) COMPLEX array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by CPOTRF.
+*
+*  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 ..
+      REAL               ONE, HALF
+      PARAMETER          ( ONE = 1.0E+0, HALF = 0.5E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K
+      REAL               AKK, BKK
+      COMPLEX            CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CHER2, CLACGV, CSSCAL, CTRMV, CTRSV,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEGS2', -INFO )
+         RETURN
+      END IF
+*
+      IF( ITYPE.EQ.1 ) THEN
+         IF( UPPER ) THEN
+*
+*           Compute inv(U')*A*inv(U)
+*
+            DO 10 K = 1, N
+*
+*              Update the upper triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL CSSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
+                  CT = -HALF*AKK
+                  CALL CLACGV( N-K, A( K, K+1 ), LDA )
+                  CALL CLACGV( N-K, B( K, K+1 ), LDB )
+                  CALL CAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL CHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA,
+     $                        B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
+                  CALL CAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL CLACGV( N-K, B( K, K+1 ), LDB )
+                  CALL CTRSV( UPLO, 'Conjugate transpose', 'Non-unit',
+     $                        N-K, B( K+1, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL CLACGV( N-K, A( K, K+1 ), LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute inv(L)*A*inv(L')
+*
+            DO 20 K = 1, N
+*
+*              Update the lower triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL CSSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
+                  CT = -HALF*AKK
+                  CALL CAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL CHER2( UPLO, N-K, -CONE, A( K+1, K ), 1,
+     $                        B( K+1, K ), 1, A( K+1, K+1 ), LDA )
+                  CALL CAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL CTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
+     $                        B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
+               END IF
+   20       CONTINUE
+         END IF
+      ELSE
+         IF( UPPER ) THEN
+*
+*           Compute U*A*U'
+*
+            DO 30 K = 1, N
+*
+*              Update the upper triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL CTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
+     $                     LDB, A( 1, K ), 1 )
+               CT = HALF*AKK
+               CALL CAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL CHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1,
+     $                     A, LDA )
+               CALL CAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL CSSCAL( K-1, BKK, A( 1, K ), 1 )
+               A( K, K ) = AKK*BKK**2
+   30       CONTINUE
+         ELSE
+*
+*           Compute L'*A*L
+*
+            DO 40 K = 1, N
+*
+*              Update the lower triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL CLACGV( K-1, A( K, 1 ), LDA )
+               CALL CTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1,
+     $                     B, LDB, A( K, 1 ), LDA )
+               CT = HALF*AKK
+               CALL CLACGV( K-1, B( K, 1 ), LDB )
+               CALL CAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL CHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ),
+     $                     LDB, A, LDA )
+               CALL CAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL CLACGV( K-1, B( K, 1 ), LDB )
+               CALL CSSCAL( K-1, BKK, A( K, 1 ), LDA )
+               CALL CLACGV( K-1, A( K, 1 ), LDA )
+               A( K, K ) = AKK*BKK**2
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of CHEGS2
+*
+      END
diff --git a/SRC/chegst.f b/SRC/chegst.f
new file mode 100644
index 00000000..f29d29e3
--- /dev/null
+++ b/SRC/chegst.f
@@ -0,0 +1,259 @@
+      SUBROUTINE CHEGST( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEGST reduces a complex Hermitian-definite generalized
+*  eigenproblem to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
+*
+*  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**H or L**H*A*L.
+*
+*  B must have been previously factorized as U**H*U or L*L**H by CPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
+*          = 2 or 3: compute U*A*U**H or L**H*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored and B is factored as
+*                  U**H*U;
+*          = 'L':  Lower triangle of A is stored and B is factored as
+*                  L*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) COMPLEX 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 transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) COMPLEX array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by CPOTRF.
+*
+*  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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      COMPLEX            CONE, HALF
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   HALF = ( 0.5E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHEGS2, CHEMM, CHER2K, CTRMM, CTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'CHEGST', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ITYPE.EQ.1 ) THEN
+            IF( UPPER ) THEN
+*
+*              Compute inv(U')*A*inv(U)
+*
+               DO 10 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(k:n,k:n)
+*
+                  CALL CHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL CTRSM( 'Left', UPLO, 'Conjugate transpose',
+     $                           'Non-unit', KB, N-K-KB+1, CONE,
+     $                           B( K, K ), LDB, A( K, K+KB ), LDA )
+                     CALL CHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB,
+     $                           CONE, A( K, K+KB ), LDA )
+                     CALL CHER2K( UPLO, 'Conjugate transpose', N-K-KB+1,
+     $                            KB, -CONE, A( K, K+KB ), LDA,
+     $                            B( K, K+KB ), LDB, ONE,
+     $                            A( K+KB, K+KB ), LDA )
+                     CALL CHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB,
+     $                           CONE, A( K, K+KB ), LDA )
+                     CALL CTRSM( 'Right', UPLO, 'No transpose',
+     $                           'Non-unit', KB, N-K-KB+1, CONE,
+     $                           B( K+KB, K+KB ), LDB, A( K, K+KB ),
+     $                           LDA )
+                  END IF
+   10          CONTINUE
+            ELSE
+*
+*              Compute inv(L)*A*inv(L')
+*
+               DO 20 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(k:n,k:n)
+*
+                  CALL CHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL CTRSM( 'Right', UPLO, 'Conjugate transpose',
+     $                           'Non-unit', N-K-KB+1, KB, CONE,
+     $                           B( K, K ), LDB, A( K+KB, K ), LDA )
+                     CALL CHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB,
+     $                           CONE, A( K+KB, K ), LDA )
+                     CALL CHER2K( UPLO, 'No transpose', N-K-KB+1, KB,
+     $                            -CONE, A( K+KB, K ), LDA,
+     $                            B( K+KB, K ), LDB, ONE,
+     $                            A( K+KB, K+KB ), LDA )
+                     CALL CHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB,
+     $                           CONE, A( K+KB, K ), LDA )
+                     CALL CTRSM( 'Left', UPLO, 'No transpose',
+     $                           'Non-unit', N-K-KB+1, KB, CONE,
+     $                           B( K+KB, K+KB ), LDB, A( K+KB, K ),
+     $                           LDA )
+                  END IF
+   20          CONTINUE
+            END IF
+         ELSE
+            IF( UPPER ) THEN
+*
+*              Compute U*A*U'
+*
+               DO 30 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL CTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
+     $                        K-1, KB, CONE, B, LDB, A( 1, K ), LDA )
+                  CALL CHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, CONE, A( 1, K ),
+     $                        LDA )
+                  CALL CHER2K( UPLO, 'No transpose', K-1, KB, CONE,
+     $                         A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
+     $                         LDA )
+                  CALL CHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, CONE, A( 1, K ),
+     $                        LDA )
+                  CALL CTRMM( 'Right', UPLO, 'Conjugate transpose',
+     $                        'Non-unit', K-1, KB, CONE, B( K, K ), LDB,
+     $                        A( 1, K ), LDA )
+                  CALL CHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   30          CONTINUE
+            ELSE
+*
+*              Compute L'*A*L
+*
+               DO 40 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL CTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
+     $                        KB, K-1, CONE, B, LDB, A( K, 1 ), LDA )
+                  CALL CHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, CONE, A( K, 1 ),
+     $                        LDA )
+                  CALL CHER2K( UPLO, 'Conjugate transpose', K-1, KB,
+     $                         CONE, A( K, 1 ), LDA, B( K, 1 ), LDB,
+     $                         ONE, A, LDA )
+                  CALL CHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, CONE, A( K, 1 ),
+     $                        LDA )
+                  CALL CTRMM( 'Left', UPLO, 'Conjugate transpose',
+     $                        'Non-unit', KB, K-1, CONE, B( K, K ), LDB,
+     $                        A( K, 1 ), LDA )
+                  CALL CHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      RETURN
+*
+*     End of CHEGST
+*
+      END
diff --git a/SRC/chegv.f b/SRC/chegv.f
new file mode 100644
index 00000000..f68db722
--- /dev/null
+++ b/SRC/chegv.f
@@ -0,0 +1,232 @@
+      SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, 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, ITYPE, LDA, LDB, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian 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.
+*
+*  A       (input/output) COMPLEX 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
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**H*B*Z = I;
+*          if ITYPE = 3, Z**H*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB, N)
+*          On entry, the Hermitian positive definite matrix B.
+*          If UPLO = 'U', the leading N-by-N upper triangular part of B
+*          contains the upper triangular part of the matrix B.
+*          If UPLO = 'L', the leading N-by-N lower triangular part of B
+*          contains the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**H*U or B = L*L**H.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) COMPLEX 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 CHETRD 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) REAL 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:  CPOTRF or CHEEV returned an error code:
+*             <= N:  if INFO = i, CHEEV 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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKOPT, NB, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHEEV, CHEGST, CPOTRF, CTRMM, CTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ. -1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'CHETRD', 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 ) THEN
+            INFO = -11
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEGV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL CPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, 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 = 'C'
+            END IF
+*
+            CALL CTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL CTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CHEGV
+*
+      END
diff --git a/SRC/chegvd.f b/SRC/chegvd.f
new file mode 100644
index 00000000..d8e592ec
--- /dev/null
+++ b/SRC/chegvd.f
@@ -0,0 +1,307 @@
+      SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+     $                   LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, LDA, LDB, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian and B is also positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  A       (input/output) COMPLEX 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
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**H*B*Z = I;
+*          if ITYPE = 3, Z**H*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB, N)
+*          On entry, the Hermitian matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**H*U or B = L*L**H.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) COMPLEX 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.
+*          If N <= 1,                LWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LWORK >= N + 1.
+*          If JOBZ  = 'V' and N > 1, LWORK >= 2*N + N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of the array RWORK.
+*          If N <= 1,                LRWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LRWORK >= N.
+*          If JOBZ  = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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.
+*          If N <= 1,                LIWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  CPOTRF or CHEEVD returned an error code:
+*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm
+*                    failed to converge; i off-diagonal elements of an
+*                    intermediate tridiagonal form did not converge to
+*                    zero;
+*                    if INFO = i and JOBZ = 'V', then the algorithm
+*                    failed to compute an eigenvalue while working on
+*                    the submatrix lying in rows and columns INFO/(N+1)
+*                    through mod(INFO,N+1);
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  Modified so that no backsubstitution is performed if CHEEVD fails to
+*  converge (NEIG in old code could be greater than N causing out of
+*  bounds reference to A - reported by Ralf Meyer).  Also corrected the
+*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LIOPT, LIWMIN, LOPT, LROPT, LRWMIN, LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHEEVD, CHEGST, CPOTRF, CTRMM, CTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LWMIN = 1
+         LRWMIN = 1
+         LIWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LWMIN = 2*N + N*N
+         LRWMIN = 1 + 5*N + 2*N*N
+         LIWMIN = 3 + 5*N
+      ELSE
+         LWMIN = N + 1
+         LRWMIN = N
+         LIWMIN = 1
+      END IF
+      LOPT = LWMIN
+      LROPT = LRWMIN
+      LIOPT = LIWMIN
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LOPT
+         RWORK( 1 ) = LROPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL CPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK,
+     $             IWORK, LIWORK, INFO )
+      LOPT = MAX( REAL( LOPT ), REAL( WORK( 1 ) ) )
+      LROPT = MAX( REAL( LROPT ), REAL( RWORK( 1 ) ) )
+      LIOPT = MAX( REAL( LIOPT ), REAL( IWORK( 1 ) ) )
+*
+      IF( WANTZ .AND. INFO.EQ.0 ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            CALL CTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, CONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL CTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, CONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LOPT
+      RWORK( 1 ) = LROPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of CHEGVD
+*
+      END
diff --git a/SRC/chegvx.f b/SRC/chegvx.f
new file mode 100644
index 00000000..1566e535
--- /dev/null
+++ b/SRC/chegvx.f
@@ -0,0 +1,336 @@
+      SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
+     $                   VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
+     $                   LWORK, RWORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHEGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian and B is also positive definite.
+*  Eigenvalues and eigenvectors can be selected by specifying either a
+*  range of values or a range of indices for the desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+**
+*  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.
+*
+*  A       (input/output) COMPLEX 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,  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).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB, N)
+*          On entry, the Hermitian matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**H*U or B = L*L**H.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) COMPLEX 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).
+*          For optimal efficiency, LWORK >= (NB+1)*N,
+*          where NB is the blocksize for CHETRD 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) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  CPOTRF or CHEEVX returned an error code:
+*             <= N:  if INFO = i, CHEEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHEEVX, CHEGST, CPOTRF, CTRMM, CTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF (INFO.EQ.0) THEN
+         IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'CHETRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( 1, ( NB + 1 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHEGVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL CPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
+     $             M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL,
+     $             INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            CALL CTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
+     $                  LDB, Z, LDZ )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL CTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
+     $                  LDB, Z, LDZ )
+         END IF
+      END IF
+*
+*     Set WORK(1) to optimal complex workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CHEGVX
+*
+      END
diff --git a/SRC/cherfs.f b/SRC/cherfs.f
new file mode 100644
index 00000000..673026dc
--- /dev/null
+++ b/SRC/cherfs.f
@@ -0,0 +1,343 @@
+      SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHERFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian indefinite, and
+*  provides error bounds and backward error estimates for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX 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.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input) COMPLEX array, dimension (LDAF,N)
+*          The factored form of the matrix A.  AF contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**H or
+*          A = L*D*L**H as computed by CHETRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CHETRF.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CHETRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CHEMV, CHETRS, CLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHERFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CHEMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( REAL( A( K, K ) ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( REAL( A( K, K ) ) )*XK
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CHETRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CHETRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CHETRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CHERFS
+*
+      END
diff --git a/SRC/chesv.f b/SRC/chesv.f
new file mode 100644
index 00000000..f51025e4
--- /dev/null
+++ b/SRC/chesv.f
@@ -0,0 +1,174 @@
+      SUBROUTINE CHESV( 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( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHESV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**H,  if UPLO = 'U', or
+*     A = L * D * L**H,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is Hermitian 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) COMPLEX 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 block diagonal matrix D and the
+*          multipliers used to obtain the factor U or L from the
+*          factorization A = U*D*U**H or A = L*D*L**H as computed by
+*          CHETRF.
+*
+*  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 CHETRF.  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) COMPLEX 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) COMPLEX 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
+*          CHETRF.
+*
+*          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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHETRF, CHETRS, 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, 'CHETRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHESV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CHESV
+*
+      END
diff --git a/SRC/chesvx.f b/SRC/chesvx.f
new file mode 100644
index 00000000..bb9d5d2a
--- /dev/null
+++ b/SRC/chesvx.f
@@ -0,0 +1,300 @@
+      SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+     $                   LDB, X, LDX, RCOND, FERR, BERR, 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          FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHESVX uses the diagonal pivoting factorization to compute the
+*  solution to a complex system of linear equations A * X = B,
+*  where A is an N-by-N Hermitian 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 = 'N', the diagonal pivoting method is used to factor A.
+*     The form of the factorization is
+*        A = U * D * U**H,  if UPLO = 'U', or
+*        A = L * D * L**H,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices, and D is Hermitian and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AF and IPIV contain the factored form
+*                  of A.  A, AF and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX 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.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input or output) COMPLEX array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by CHETRF.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H.
+*
+*  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 details of the interchanges and the block structure
+*          of D, as determined by CHETRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by CHETRF.
+*
+*  B       (input) COMPLEX array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= max(1,2*N), and for best
+*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
+*          NB is the optimal blocksize for CHETRF.
+*
+*          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) REAL 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:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOFACT
+      INTEGER            LWKOPT, NB
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANHE, SLAMCH
+      EXTERNAL           ILAENV, LSAME, CLANHE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHECON, CHERFS, CHETRF, CHETRS, CLACPY, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKOPT = MAX( 1, 2*N )
+         IF( NOFACT ) THEN
+            NB = ILAENV( 1, 'CHETRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = MAX( LWKOPT, N*NB )
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHESVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL CLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL CHETRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANHE( 'I', UPLO, N, A, LDA, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CHECON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CHETRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CHESVX
+*
+      END
diff --git a/SRC/chetd2.f b/SRC/chetd2.f
new file mode 100644
index 00000000..e1b51f2a
--- /dev/null
+++ b/SRC/chetd2.f
@@ -0,0 +1,258 @@
+      SUBROUTINE CHETD2( 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 ..
+      REAL               D( * ), E( * )
+      COMPLEX            A( LDA, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHETD2 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 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) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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 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            ONE, ZERO, HALF
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   HALF = ( 0.5E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      COMPLEX            ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CHEMV, CHER2, CLARFG, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. 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( 'CHETD2', -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 ) = REAL( 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 CLARFG( 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 CHEMV( 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*CDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
+               CALL CAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL CHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
+     $                     LDA )
+*
+            ELSE
+               A( I, I ) = REAL( 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 ) = REAL( 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 CLARFG( 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 CHEMV( 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*CDOTC( N-I, TAU( I ), 1, A( I+1, I ),
+     $                 1 )
+               CALL CAXPY( 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 CHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
+     $                     A( I+1, I+1 ), LDA )
+*
+            ELSE
+               A( I+1, I+1 ) = REAL( 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 CHETD2
+*
+      END
diff --git a/SRC/chetf2.f b/SRC/chetf2.f
new file mode 100644
index 00000000..022cbc78
--- /dev/null
+++ b/SRC/chetf2.f
@@ -0,0 +1,551 @@
+      SUBROUTINE CHETF2( 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( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHETF2 computes the factorization of a complex Hermitian 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 conjugate transpose of U, and D is
+*  Hermitian 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
+*          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 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, 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.210 and l.392
+*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*    by
+*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(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
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
+      REAL               ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
+     $                   TT
+      COMPLEX            D12, D21, T, WK, WKM1, WKP1, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, SISNAN
+      INTEGER            ICAMAX
+      REAL               SLAPY2
+      EXTERNAL           LSAME, ICAMAX, SLAPY2, SISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHER, CSSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CHETF2', -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 90
+         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( REAL( 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 = ICAMAX( K-1, A( 1, K ), 1 )
+            COLMAX = CABS1( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
+*
+*           Column K is zero or contains a NaN: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+            A( K, K ) = REAL( A( K, 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 + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( REAL( 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 CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+               DO 20 J = KP + 1, KK - 1
+                  T = CONJG( A( J, KK ) )
+                  A( J, KK ) = CONJG( A( KP, J ) )
+                  A( KP, J ) = T
+   20          CONTINUE
+               A( KP, KK ) = CONJG( A( KP, KK ) )
+               R1 = REAL( A( KK, KK ) )
+               A( KK, KK ) = REAL( A( KP, KP ) )
+               A( KP, KP ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  A( K, K ) = REAL( A( K, K ) )
+                  T = A( K-1, K )
+                  A( K-1, K ) = A( KP, K )
+                  A( KP, K ) = T
+               END IF
+            ELSE
+               A( K, K ) = REAL( A( K, K ) )
+               IF( KSTEP.EQ.2 )
+     $            A( K-1, K-1 ) = REAL( A( K-1, K-1 ) )
+            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 / REAL( A( K, K ) )
+               CALL CHER( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+*              Store U(k) in column k
+*
+               CALL CSSCAL( 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
+*
+                  D = SLAPY2( REAL( A( K-1, K ) ),
+     $                AIMAG( A( K-1, K ) ) )
+                  D22 = REAL( A( K-1, K-1 ) ) / D
+                  D11 = REAL( A( K, K ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D12 = A( K-1, K ) / D
+                  D = TT / D
+*
+                  DO 40 J = K - 2, 1, -1
+                     WKM1 = D*( D11*A( J, K-1 )-CONJG( D12 )*A( J, K ) )
+                     WK = D*( D22*A( J, K )-D12*A( J, K-1 ) )
+                     DO 30 I = J, 1, -1
+                        A( I, J ) = A( I, J ) - A( I, K )*CONJG( WK ) -
+     $                              A( I, K-1 )*CONJG( WKM1 )
+   30                CONTINUE
+                     A( J, K ) = WK
+                     A( J, K-1 ) = WKM1
+                     A( J, J ) = CMPLX( REAL( A( J, J ) ), 0.0E+0 )
+   40             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
+   50    CONTINUE
+*
+*        If K > N, exit from loop
+*
+         IF( K.GT.N )
+     $      GO TO 90
+         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( REAL( 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 + ICAMAX( N-K, A( K+1, K ), 1 )
+            COLMAX = CABS1( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
+*
+*           Column K is zero or contains a NaN: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+            A( K, K ) = REAL( A( K, 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 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( REAL( 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 CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+               DO 60 J = KK + 1, KP - 1
+                  T = CONJG( A( J, KK ) )
+                  A( J, KK ) = CONJG( A( KP, J ) )
+                  A( KP, J ) = T
+   60          CONTINUE
+               A( KP, KK ) = CONJG( A( KP, KK ) )
+               R1 = REAL( A( KK, KK ) )
+               A( KK, KK ) = REAL( A( KP, KP ) )
+               A( KP, KP ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  A( K, K ) = REAL( A( K, K ) )
+                  T = A( K+1, K )
+                  A( K+1, K ) = A( KP, K )
+                  A( KP, K ) = T
+               END IF
+            ELSE
+               A( K, K ) = REAL( A( K, K ) )
+               IF( KSTEP.EQ.2 )
+     $            A( K+1, K+1 ) = REAL( A( K+1, K+1 ) )
+            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 / REAL( A( K, K ) )
+                  CALL CHER( UPLO, N-K, -R1, A( K+1, K ), 1,
+     $                       A( K+1, K+1 ), LDA )
+*
+*                 Store L(k) in column K
+*
+                  CALL CSSCAL( N-K, R1, 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 - ( 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) )'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D = SLAPY2( REAL( A( K+1, K ) ),
+     $                        AIMAG( A( K+1, K ) ) )
+                  D11 = REAL( A( K+1, K+1 ) ) / D
+                  D22 = REAL( A( K, K ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D21 = A( K+1, K ) / D
+                  D =  TT / D
+*
+                  DO 80 J = K + 2, N
+                     WK = D*( D11*A( J, K )-D21*A( J, K+1 ) )
+                     WKP1 = D*( D22*A( J, K+1 )-CONJG( D21 )*A( J, K ) )
+                     DO 70 I = J, N
+                        A( I, J ) = A( I, J ) - A( I, K )*CONJG( WK ) -
+     $                              A( I, K+1 )*CONJG( WKP1 )
+   70                CONTINUE
+                     A( J, K ) = WK
+                     A( J, K+1 ) = WKP1
+                     A( J, J ) = CMPLX( REAL( A( J, J ) ), 0.0E+0 )
+   80             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 50
+*
+      END IF
+*
+   90 CONTINUE
+      RETURN
+*
+*     End of CHETF2
+*
+      END
diff --git a/SRC/chetrd.f b/SRC/chetrd.f
new file mode 100644
index 00000000..a9166577
--- /dev/null
+++ b/SRC/chetrd.f
@@ -0,0 +1,296 @@
+      SUBROUTINE CHETRD( 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 ..
+      REAL               D( * ), E( * )
+      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHETRD 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 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) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHER2K, CHETD2, CLATRD, 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, 'CHETRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHETRD', -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, 'CHETRD', 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, 'CHETRD', 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 CLATRD( 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 CHER2K( 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 CHETD2( 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 CLATRD( 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 CHER2K( 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 CHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+     $                TAU( I ), IINFO )
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of CHETRD
+*
+      END
diff --git a/SRC/chetrf.f b/SRC/chetrf.f
new file mode 100644
index 00000000..520bc356
--- /dev/null
+++ b/SRC/chetrf.f
@@ -0,0 +1,281 @@
+      SUBROUTINE CHETRF( 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( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHETRF computes the factorization of a complex Hermitian matrix A
+*  using the Bunch-Kaufman diagonal pivoting method.  The form of the
+*  factorization is
+*
+*     A = U*D*U**H  or  A = L*D*L**H
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is Hermitian 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) COMPLEX 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, 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) COMPLEX 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.
+*
+*  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           CHETF2, CLAHEF, 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, 'CHETRF', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHETRF', -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, 'CHETRF', 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 CLAHEF;
+*        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 CLAHEF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns 1:k of A
+*
+            CALL CHETF2( 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 CLAHEF;
+*        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 CLAHEF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+     $                   WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns k:n of A
+*
+            CALL CHETF2( 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 CHETRF
+*
+      END
diff --git a/SRC/chetri.f b/SRC/chetri.f
new file mode 100644
index 00000000..8bf8500e
--- /dev/null
+++ b/SRC/chetri.f
@@ -0,0 +1,327 @@
+      SUBROUTINE CHETRI( 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( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHETRI computes the inverse of a complex Hermitian indefinite matrix
+*  A using the factorization A = U*D*U**H or A = L*D*L**H computed by
+*  CHETRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX 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 CHETRF.
+*
+*          On exit, if INFO = 0, the (Hermitian) 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 CHETRF.
+*
+*  WORK    (workspace) COMPLEX 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 ..
+      REAL               ONE
+      COMPLEX            CONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KP, KSTEP
+      REAL               AK, AKP1, D, T
+      COMPLEX            AKKP1, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CHEMV, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, REAL
+*     ..
+*     .. 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( 'CHETRI', -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 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            A( K, K ) = ONE / REAL( A( K, K ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - REAL( CDOTC( 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 = REAL( A( K, K ) ) / T
+            AKP1 = REAL( 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 CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - REAL( CDOTC( K-1, WORK, 1, A( 1,
+     $                     K ), 1 ) )
+               A( K, K+1 ) = A( K, K+1 ) -
+     $                       CDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+               CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+               CALL CHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K+1 ), 1 )
+               A( K+1, K+1 ) = A( K+1, K+1 ) -
+     $                         REAL( CDOTC( 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 CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+            DO 40 J = KP + 1, K - 1
+               TEMP = CONJG( A( J, K ) )
+               A( J, K ) = CONJG( A( KP, J ) )
+               A( KP, J ) = TEMP
+   40       CONTINUE
+            A( KP, K ) = CONJG( A( KP, K ) )
+            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
+   50    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
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            A( K, K ) = ONE / REAL( A( K, K ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+     $                     1, ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - REAL( CDOTC( 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 = REAL( A( K-1, K-1 ) ) / T
+            AKP1 = REAL( 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 CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL CHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+     $                     1, ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - REAL( CDOTC( N-K, WORK, 1,
+     $                     A( K+1, K ), 1 ) )
+               A( K, K-1 ) = A( K, K-1 ) -
+     $                       CDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+     $                       1 )
+               CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+               CALL CHEMV( UPLO, N-K, -CONE, 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 ) -
+     $                         REAL( CDOTC( 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 CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+            DO 70 J = K + 1, KP - 1
+               TEMP = CONJG( A( J, K ) )
+               A( J, K ) = CONJG( A( KP, J ) )
+               A( KP, J ) = TEMP
+   70       CONTINUE
+            A( KP, K ) = CONJG( A( KP, K ) )
+            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 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHETRI
+*
+      END
diff --git a/SRC/chetrs.f b/SRC/chetrs.f
new file mode 100644
index 00000000..8a96f3f6
--- /dev/null
+++ b/SRC/chetrs.f
@@ -0,0 +1,393 @@
+      SUBROUTINE CHETRS( 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( * )
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHETRS solves a system of linear equations A*X = B with a complex
+*  Hermitian matrix A using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by CHETRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  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 array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CHETRF.
+*
+*  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 CHETRF.
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KP
+      REAL               S
+      COMPLEX            AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, MAX, REAL
+*     ..
+*     .. 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( 'CHETRS', -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 CSWAP( 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 CGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            S = REAL( ONE ) / REAL( A( K, K ) )
+            CALL CSSCAL( NRHS, S, 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 CSWAP( 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 CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL CGERU( 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 ) / CONJG( AKM1K )
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / CONJG( 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.
+*
+            IF( K.GT.1 ) THEN
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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.
+*
+            IF( K.GT.1 ) THEN
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CSWAP( 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 CGERU( 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.
+*
+            S = REAL( ONE ) / REAL( A( K, K ) )
+            CALL CSSCAL( NRHS, S, 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 CSWAP( 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 CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL CGERU( 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 ) / CONJG( AKM1K )
+            AK = A( K+1, K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / CONJG( 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 ) THEN
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE,
+     $                     B( K-1, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHETRS
+*
+      END
diff --git a/SRC/chgeqz.f b/SRC/chgeqz.f
new file mode 100644
index 00000000..9593179a
--- /dev/null
+++ b/SRC/chgeqz.f
@@ -0,0 +1,758 @@
+      SUBROUTINE CHGEQZ( 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 ..
+      REAL               RWORK( * )
+      COMPLEX            ALPHA( * ), BETA( * ), H( LDH, * ),
+     $                   Q( LDQ, * ), T( LDT, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHGEQZ 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 CGGHRD.
+*  
+*  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 CGGHRD 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 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 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 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 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 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 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 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) REAL 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            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               HALF
+      PARAMETER          ( HALF = 0.5E+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
+      REAL               ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL,
+     $                   C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
+      COMPLEX            ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
+     $                   CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1,
+     $                   U12, X
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHS, SLAMCH
+      EXTERNAL           LSAME, CLANHS, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARTG, CLASET, CROT, CSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( 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( 'CHGEQZ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+c     WORK( 1 ) = CMPLX( 1 )
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = CMPLX( 1 )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
+*
+*     Machine Constants
+*
+      IN = IHI + 1 - ILO
+      SAFMIN = SLAMCH( 'S' )
+      ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
+      ANORM = CLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK )
+      BNORM = CLANHS( '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 = CONJG( T( J, J ) / ABSB )
+            T( J, J ) = ABSB
+            IF( ILSCHR ) THEN
+               CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 )
+               CALL CSCAL( J, SIGNBC, H( 1, J ), 1 )
+            ELSE
+               H( J, J ) = H( J, J )*SIGNBC
+            END IF
+            IF( ILZ )
+     $         CALL CSCAL( 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 CLARTG( CTEMP, H( JCH+1, JCH ), C, S,
+     $                            H( JCH, JCH ) )
+                     H( JCH+1, JCH ) = CZERO
+                     CALL CROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
+     $                          H( JCH+1, JCH+1 ), LDH, C, S )
+                     CALL CROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
+     $                          T( JCH+1, JCH+1 ), LDT, C, S )
+                     IF( ILQ )
+     $                  CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, CONJG( 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 CLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S,
+     $                            T( JCH, JCH+1 ) )
+                     T( JCH+1, JCH+1 ) = CZERO
+                     IF( JCH.LT.ILASTM-1 )
+     $                  CALL CROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
+     $                             T( JCH+1, JCH+2 ), LDT, C, S )
+                     CALL CROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
+     $                          H( JCH+1, JCH-1 ), LDH, C, S )
+                     IF( ILQ )
+     $                  CALL CROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, CONJG( S ) )
+                     CTEMP = H( JCH+1, JCH )
+                     CALL CLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S,
+     $                            H( JCH+1, JCH ) )
+                     H( JCH+1, JCH-1 ) = CZERO
+                     CALL CROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
+     $                          H( IFRSTM, JCH-1 ), 1, C, S )
+                     CALL CROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
+     $                          T( IFRSTM, JCH-1 ), 1, C, S )
+                     IF( ILZ )
+     $                  CALL CROT( 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 CLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S,
+     $                H( ILAST, ILAST ) )
+         H( ILAST, ILAST-1 ) = CZERO
+         CALL CROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
+     $              H( IFRSTM, ILAST-1 ), 1, C, S )
+         CALL CROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
+     $              T( IFRSTM, ILAST-1 ), 1, C, S )
+         IF( ILZ )
+     $      CALL CROT( 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 = CONJG( T( ILAST, ILAST ) / ABSB )
+            T( ILAST, ILAST ) = ABSB
+            IF( ILSCHR ) THEN
+               CALL CSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 )
+               CALL CSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ),
+     $                     1 )
+            ELSE
+               H( ILAST, ILAST ) = H( ILAST, ILAST )*SIGNBC
+            END IF
+            IF( ILZ )
+     $         CALL CSCAL( 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 = REAL( T1-ABI22 )*REAL( RTDISC ) +
+     $             AIMAG( T1-ABI22 )*AIMAG( 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 + CONJG( ( 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 CLARTG( CTEMP, CTEMP2, C, S, CTEMP3 )
+*
+*        Sweep
+*
+         DO 150 J = ISTART, ILAST - 1
+            IF( J.GT.ISTART ) THEN
+               CTEMP = H( J, J-1 )
+               CALL CLARTG( 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 ) = -CONJG( 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 ) = -CONJG( 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 ) + CONJG( 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 CLARTG( 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 ) = -CONJG( 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 ) = -CONJG( 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 ) = -CONJG( 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 = CONJG( T( J, J ) / ABSB )
+            T( J, J ) = ABSB
+            IF( ILSCHR ) THEN
+               CALL CSCAL( J-1, SIGNBC, T( 1, J ), 1 )
+               CALL CSCAL( J, SIGNBC, H( 1, J ), 1 )
+            ELSE
+               H( J, J ) = H( J, J )*SIGNBC
+            END IF
+            IF( ILZ )
+     $         CALL CSCAL( 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 ) = CMPLX( N )
+      RETURN
+*
+*     End of CHGEQZ
+*
+      END
diff --git a/SRC/chpcon.f b/SRC/chpcon.f
new file mode 100644
index 00000000..8ff610c7
--- /dev/null
+++ b/SRC/chpcon.f
@@ -0,0 +1,159 @@
+      SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPCON estimates the reciprocal of the condition number of a complex
+*  Hermitian packed matrix A using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by CHPTRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CHPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CHPTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IP, KASE
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPTRS, CLACN2, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         IP = N*( N+1 ) / 2
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP - I
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         IP = 1
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP + N - I + 1
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL CHPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of CHPCON
+*
+      END
diff --git a/SRC/chpev.f b/SRC/chpev.f
new file mode 100644
index 00000000..855203ba
--- /dev/null
+++ b/SRC/chpev.f
@@ -0,0 +1,196 @@
+      SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, 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, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPEV computes all the eigenvalues and, optionally, eigenvectors of a
+*  complex Hermitian matrix 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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX 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) COMPLEX array, dimension (max(1, 2*N-1))
+*
+*  RWORK   (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
+     $                   ISCALE
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHP, SLAMCH
+      EXTERNAL           LSAME, CLANHP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPTRD, CSSCAL, CSTEQR, CUPGTR, SSCAL, SSTERF,
+     $                   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, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          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( 'CHPEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         RWORK( 1 ) = 1
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = CLANHP( 'M', UPLO, N, AP, 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 ) THEN
+         CALL CSSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      CALL CHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
+     $             IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     CUPGTR to generate the orthogonal matrix, then call CSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         INDWRK = INDTAU + N
+         CALL CUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+         INDRWK = INDE + N
+         CALL CSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
+     $                RWORK( INDRWK ), 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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of CHPEV
+*
+      END
diff --git a/SRC/chpevd.f b/SRC/chpevd.f
new file mode 100644
index 00000000..bbb53503
--- /dev/null
+++ b/SRC/chpevd.f
@@ -0,0 +1,285 @@
+      SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
+     $                   RWORK, LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPEVD computes all the eigenvalues and, optionally, eigenvectors of
+*  a complex Hermitian matrix A in packed storage.  If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX 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/output) COMPLEX array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of array WORK.
+*          If N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LRWORK must be at least
+*                    1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
+     $                   ISCALE, LIWMIN, LLRWK, LLWRK, LRWMIN, LWMIN
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHP, SLAMCH
+      EXTERNAL           LSAME, CLANHP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPTRD, CSSCAL, CSTEDC, CUPMTR, SSCAL, SSTERF,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LWMIN = 2*N
+               LRWMIN = 1 + 5*N + 2*N**2
+               LIWMIN = 3 + 5*N
+            ELSE
+               LWMIN = N
+               LRWMIN = N
+               LIWMIN = 1
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -9
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPEVD', -INFO )
+         RETURN 
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = CONE
+         RETURN 
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = CLANHP( 'M', UPLO, N, AP, 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 ) THEN
+         CALL CSSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      INDRWK = INDE + N
+      INDWRK = INDTAU + N
+      LLWRK = LWORK - INDWRK + 1
+      LLRWK = LRWORK - INDRWK + 1
+      CALL CHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
+     $             IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     CUPGTR to generate the orthogonal matrix, then call CSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL CSTEDC( 'I', N, W, RWORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                LLWRK, RWORK( INDRWK ), LLRWK, IWORK, LIWORK,
+     $                INFO )
+         CALL CUPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of CHPEVD
+*
+      END
diff --git a/SRC/chpevx.f b/SRC/chpevx.f
new file mode 100644
index 00000000..0a2e36d4
--- /dev/null
+++ b/SRC/chpevx.f
@@ -0,0 +1,388 @@
+      SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian matrix A in packed storage.
+*  Eigenvalues/vectors can be selected by specifying either a range of
+*  values or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the selected eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and
+*          the index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
+     $                   ITMP1, J, JJ, NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHP, SLAMCH
+      EXTERNAL           LSAME, CLANHP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPTRD, CSSCAL, CSTEIN, CSTEQR, CSWAP, CUPGTR,
+     $                   CUPMTR, SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -14
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = AP( 1 )
+         ELSE
+            IF( VL.LT.REAL( AP( 1 ) ) .AND. VU.GE.REAL( AP( 1 ) ) ) THEN
+               M = 1
+               W( 1 ) = AP( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF ( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      ENDIF
+      ANRM = CLANHP( 'M', UPLO, N, AP, RWORK )
+      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 CSSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      CALL CHPTRD( UPLO, N, AP, RWORK( INDD ), RWORK( INDE ),
+     $             WORK( INDTAU ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call SSTERF or CUPGTR and CSTEQR.  If this fails
+*     for some eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL SCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL SSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL CUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                   WORK( INDWRK ), IINFO )
+            CALL SCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL CSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 20
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL CSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by CSTEIN.
+*
+         INDWRK = INDTAU + N
+         CALL CUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   20 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 40 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 30 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   30       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHPEVX
+*
+      END
diff --git a/SRC/chpgst.f b/SRC/chpgst.f
new file mode 100644
index 00000000..3d727010
--- /dev/null
+++ b/SRC/chpgst.f
@@ -0,0 +1,215 @@
+      SUBROUTINE CHPGST( 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 ..
+      COMPLEX            AP( * ), BP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPGST reduces a complex Hermitian-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**H)*A*inv(U) or inv(L)*A*inv(L**H)
+*
+*  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**H or L**H*A*L.
+*
+*  B must have been previously factorized as U**H*U or L*L**H by CPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
+*          = 2 or 3: compute U*A*U**H or L**H*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored and B is factored as
+*                  U**H*U;
+*          = 'L':  Lower triangle of A is stored and B is factored as
+*                  L*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX 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 CPPTRF.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, HALF
+      PARAMETER          ( ONE = 1.0E+0, HALF = 0.5E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
+      REAL               AJJ, AKK, BJJ, BKK
+      COMPLEX            CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CHPMV, CHPR2, CSSCAL, CTPMV, CTPSV,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. 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( 'CHPGST', -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
+*
+               AP( JJ ) = REAL( AP( JJ ) )
+               BJJ = BP( JJ )
+               CALL CTPSV( UPLO, 'Conjugate transpose', 'Non-unit', J,
+     $                     BP, AP( J1 ), 1 )
+               CALL CHPMV( UPLO, J-1, -CONE, AP, BP( J1 ), 1, CONE,
+     $                     AP( J1 ), 1 )
+               CALL CSSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
+               AP( JJ ) = ( AP( JJ )-CDOTC( 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 CSSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
+                  CT = -HALF*AKK
+                  CALL CAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL CHPR2( UPLO, N-K, -CONE, AP( KK+1 ), 1,
+     $                        BP( KK+1 ), 1, AP( K1K1 ) )
+                  CALL CAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL CTPSV( 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 CTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
+     $                     AP( K1 ), 1 )
+               CT = HALF*AKK
+               CALL CAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL CHPR2( UPLO, K-1, CONE, AP( K1 ), 1, BP( K1 ), 1,
+     $                     AP )
+               CALL CAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL CSSCAL( 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 + CDOTC( N-J, AP( JJ+1 ), 1,
+     $                    BP( JJ+1 ), 1 )
+               CALL CSSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
+               CALL CHPMV( UPLO, N-J, CONE, AP( J1J1 ), BP( JJ+1 ), 1,
+     $                     CONE, AP( JJ+1 ), 1 )
+               CALL CTPMV( UPLO, 'Conjugate transpose', 'Non-unit',
+     $                     N-J+1, BP( JJ ), AP( JJ ), 1 )
+               JJ = J1J1
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of CHPGST
+*
+      END
diff --git a/SRC/chpgv.f b/SRC/chpgv.f
new file mode 100644
index 00000000..ce937f06
--- /dev/null
+++ b/SRC/chpgv.f
@@ -0,0 +1,196 @@
+      SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                  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, ITYPE, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPGV computes all the eigenvalues and, optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian, 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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage
+*          format as B.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX 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**H*B*Z = I;
+*          if ITYPE = 3, Z**H*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) COMPLEX array, dimension (max(1, 2*N-1))
+*
+*  RWORK   (workspace) REAL 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:  CPPTRF or CHPEV returned an error code:
+*             <= N:  if INFO = i, CHPEV failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not convergeto 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           CHPEV, CHPGST, CPPTRF, CTPMV, CTPSV, 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( 'CHPGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL CPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL CHPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, 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 = 'C'
+            END IF
+*
+            DO 10 J = 1, NEIG
+               CALL CTPSV( 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 = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, NEIG
+               CALL CTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of CHPGV
+*
+      END
diff --git a/SRC/chpgvd.f b/SRC/chpgvd.f
new file mode 100644
index 00000000..970fce4e
--- /dev/null
+++ b/SRC/chpgvd.f
@@ -0,0 +1,295 @@
+      SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                   LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPGVD computes all the eigenvalues and, optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian, stored in packed format, and B is also
+*  positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage
+*          format as B.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX 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**H*B*Z = I;
+*          if ITYPE = 3, Z**H*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) COMPLEX array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of array WORK.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 2*N.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) REAL array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LRWORK >= N.
+*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  CPPTRF or CHPEVD returned an error code:
+*             <= N:  if INFO = i, CHPEVD failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not convergeto 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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J, LIWMIN, LRWMIN, LWMIN, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPEVD, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LWMIN = 2*N
+               LRWMIN = 1 + 5*N + 2*N**2
+               LIWMIN = 3 + 5*N
+            ELSE
+               LWMIN = N
+               LRWMIN = N
+               LIWMIN = 1
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL CPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL CHPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK,
+     $             LRWORK, IWORK, LIWORK, INFO )
+      LWMIN = MAX( REAL( LWMIN ), REAL( WORK( 1 ) ) )
+      LRWMIN = MAX( REAL( LRWMIN ), REAL( RWORK( 1 ) ) )
+      LIWMIN = MAX( REAL( LIWMIN ), REAL( IWORK( 1 ) ) )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            DO 10 J = 1, NEIG
+               CALL CTPSV( 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 = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, NEIG
+               CALL CTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of CHPGVD
+*
+      END
diff --git a/SRC/chpgvx.f b/SRC/chpgvx.f
new file mode 100644
index 00000000..4370b9df
--- /dev/null
+++ b/SRC/chpgvx.f
@@ -0,0 +1,293 @@
+      SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
+     $                   IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               RWORK( * ), W( * )
+      COMPLEX            AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPGVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian, stored in packed format, and B is also
+*  positive definite.  Eigenvalues and eigenvectors can be selected by
+*  specifying either a range of values or a range of indices for the
+*  desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage
+*          format as B.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, N)
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**H*B*Z = I;
+*          if ITYPE = 3, Z**H*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  CPPTRF or CHPEVX returned an error code:
+*             <= N:  if INFO = i, CHPEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPEVX, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE 
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL ) THEN
+               INFO = -9
+            END IF
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 ) THEN
+               INFO = -10
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -11
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL CPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL CHPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
+     $             W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            DO 10 J = 1, M
+               CALL CTPSV( 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 = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, M
+               CALL CTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CHPGVX
+*
+      END
diff --git a/SRC/chprfs.f b/SRC/chprfs.f
new file mode 100644
index 00000000..e278aaa2
--- /dev/null
+++ b/SRC/chprfs.f
@@ -0,0 +1,341 @@
+      SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
+     $                   FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian indefinite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian 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.
+*
+*  AFP     (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The factored form of the matrix A.  AFP contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**H or
+*          A = L*D*L**H as computed by CHPTRF, stored as a packed
+*          triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CHPTRF.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CHPTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CHPMV, CHPTRS, CLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CHPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( REAL( AP( KK+K-1 ) ) )*
+     $                      XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( REAL( AP( KK ) ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CHPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CHPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CHPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CHPRFS
+*
+      END
diff --git a/SRC/chpsv.f b/SRC/chpsv.f
new file mode 100644
index 00000000..78091e06
--- /dev/null
+++ b/SRC/chpsv.f
@@ -0,0 +1,148 @@
+      SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian matrix stored in packed format and X
+*  and B are N-by-NRHS matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**H,  if UPLO = 'U', or
+*     A = L * D * L**H,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, D is Hermitian 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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by CHPTRF.  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) COMPLEX 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).
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPTRF, CHPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL CHPTRF( UPLO, N, AP, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of CHPSV
+*
+      END
diff --git a/SRC/chpsvx.f b/SRC/chpsvx.f
new file mode 100644
index 00000000..dca6e736
--- /dev/null
+++ b/SRC/chpsvx.f
@@ -0,0 +1,277 @@
+      SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
+     $                   LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or
+*  A = L*D*L**H to compute the solution to a complex system of linear
+*  equations A * X = B, where A is an N-by-N Hermitian matrix stored
+*  in packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+*        A = U * D * U**H,  if UPLO = 'U', or
+*        A = L * D * L**H,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices and D is Hermitian and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AFP and IPIV contain the factored form of
+*                  A.  AFP and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*  AFP     (input or output) COMPLEX array, dimension (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains details of the interchanges and the block structure
+*          of D, as determined by CHPTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by CHPTRF.
+*
+*  B       (input) COMPLEX array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHP, SLAMCH
+      EXTERNAL           LSAME, CLANHP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CHPCON, CHPRFS, CHPTRF, CHPTRS, CLACPY,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL CCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL CHPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANHP( 'I', UPLO, N, AP, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CHPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CHPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CHPSVX
+*
+      END
diff --git a/SRC/chptrd.f b/SRC/chptrd.f
new file mode 100644
index 00000000..07c146e4
--- /dev/null
+++ b/SRC/chptrd.f
@@ -0,0 +1,237 @@
+      SUBROUTINE CHPTRD( 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 ..
+      REAL               D( * ), E( * )
+      COMPLEX            AP( * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPTRD reduces a complex Hermitian matrix A stored in packed form 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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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 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.
+*
+*  D       (output) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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 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 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 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 AP,
+*  overwriting A(i+2:n,i), and tau is stored in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO, HALF
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   HALF = ( 0.5E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, I1, I1I1, II
+      COMPLEX            ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CHPMV, CHPR2, CLARFG, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL
+*     ..
+*     .. 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( 'CHPTRD', -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
+         AP( I1+N-1 ) = REAL( AP( I1+N-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)
+*
+            ALPHA = AP( I1+I-1 )
+            CALL CLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
+            E( I ) = ALPHA
+*
+            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 CHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
+     $                     1 )
+*
+*              Compute  w := y - 1/2 * tau * (y'*v) * v
+*
+               ALPHA = -HALF*TAUI*CDOTC( I, TAU, 1, AP( I1 ), 1 )
+               CALL CAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL CHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
+*
+            END IF
+            AP( I1+I-1 ) = E( I )
+            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
+         AP( 1 ) = REAL( AP( 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)
+*
+            ALPHA = AP( II+1 )
+            CALL CLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
+            E( I ) = ALPHA
+*
+            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 CHPMV( 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*CDOTC( N-I, TAU( I ), 1, AP( II+1 ),
+     $                 1 )
+               CALL CAXPY( 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 CHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
+     $                     AP( I1I1 ) )
+*
+            END IF
+            AP( II+1 ) = E( I )
+            D( I ) = AP( II )
+            TAU( I ) = TAUI
+            II = I1I1
+   20    CONTINUE
+         D( N ) = AP( II )
+      END IF
+*
+      RETURN
+*
+*     End of CHPTRD
+*
+      END
diff --git a/SRC/chptrf.f b/SRC/chptrf.f
new file mode 100644
index 00000000..65ab2192
--- /dev/null
+++ b/SRC/chptrf.f
@@ -0,0 +1,580 @@
+      SUBROUTINE CHPTRF( 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( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPTRF computes the factorization of a complex Hermitian packed
+*  matrix A using the Bunch-Kaufman diagonal pivoting method:
+*
+*     A = U*D*U**H  or  A = L*D*L**H
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is Hermitian 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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
+     $                   KSTEP, KX, NPP
+      REAL               ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX,
+     $                   TT
+      COMPLEX            D12, D21, T, WK, WKM1, WKP1, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAPY2
+      EXTERNAL           LSAME, ICAMAX, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPR, CSSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CHPTRF', -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( REAL( 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 = ICAMAX( K-1, AP( KC ), 1 )
+            COLMAX = CABS1( 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
+            AP( KC+K-1 ) = REAL( AP( KC+K-1 ) )
+         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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( AP( KX ) )
+                     JMAX = J
+                  END IF
+                  KX = KX + J
+   20          CONTINUE
+               KPC = ( IMAX-1 )*IMAX / 2 + 1
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ICAMAX( IMAX-1, AP( KPC ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( REAL( 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 CSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
+               KX = KPC + KP - 1
+               DO 30 J = KP + 1, KK - 1
+                  KX = KX + J - 1
+                  T = CONJG( AP( KNC+J-1 ) )
+                  AP( KNC+J-1 ) = CONJG( AP( KX ) )
+                  AP( KX ) = T
+   30          CONTINUE
+               AP( KX+KK-1 ) = CONJG( AP( KX+KK-1 ) )
+               R1 = REAL( AP( KNC+KK-1 ) )
+               AP( KNC+KK-1 ) = REAL( AP( KPC+KP-1 ) )
+               AP( KPC+KP-1 ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  AP( KC+K-1 ) = REAL( AP( KC+K-1 ) )
+                  T = AP( KC+K-2 )
+                  AP( KC+K-2 ) = AP( KC+KP-1 )
+                  AP( KC+KP-1 ) = T
+               END IF
+            ELSE
+               AP( KC+K-1 ) = REAL( AP( KC+K-1 ) )
+               IF( KSTEP.EQ.2 )
+     $            AP( KC-1 ) = REAL( AP( KC-1 ) )
+            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 / REAL( AP( KC+K-1 ) )
+               CALL CHPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+*              Store U(k) in column k
+*
+               CALL CSSCAL( 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
+*
+                  D = SLAPY2( REAL( AP( K-1+( K-1 )*K / 2 ) ),
+     $                AIMAG( AP( K-1+( K-1 )*K / 2 ) ) )
+                  D22 = REAL( AP( K-1+( K-2 )*( K-1 ) / 2 ) ) / D
+                  D11 = REAL( AP( K+( K-1 )*K / 2 ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D12 = AP( K-1+( K-1 )*K / 2 ) / D
+                  D = TT / D
+*
+                  DO 50 J = K - 2, 1, -1
+                     WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
+     $                      CONJG( D12 )*AP( J+( K-1 )*K / 2 ) )
+                     WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12*
+     $                    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 )*CONJG( WK ) -
+     $                     AP( I+( K-2 )*( K-1 ) / 2 )*CONJG( WKM1 )
+   40                CONTINUE
+                     AP( J+( K-1 )*K / 2 ) = WK
+                     AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
+                     AP( J+( J-1 )*J / 2 ) = CMPLX( REAL( AP( J+( J-1 )*
+     $                                       J / 2 ) ), 0.0E+0 )
+   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( REAL( 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 + ICAMAX( N-K, AP( KC+1 ), 1 )
+            COLMAX = CABS1( 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
+            AP( KC ) = REAL( AP( KC ) )
+         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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( 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 + ICAMAX( N-IMAX, AP( KPC+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( REAL( 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 CSWAP( 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 = CONJG( AP( KNC+J-KK ) )
+                  AP( KNC+J-KK ) = CONJG( AP( KX ) )
+                  AP( KX ) = T
+   80          CONTINUE
+               AP( KNC+KP-KK ) = CONJG( AP( KNC+KP-KK ) )
+               R1 = REAL( AP( KNC ) )
+               AP( KNC ) = REAL( AP( KPC ) )
+               AP( KPC ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  AP( KC ) = REAL( AP( KC ) )
+                  T = AP( KC+1 )
+                  AP( KC+1 ) = AP( KC+KP-K )
+                  AP( KC+KP-K ) = T
+               END IF
+            ELSE
+               AP( KC ) = REAL( AP( KC ) )
+               IF( KSTEP.EQ.2 )
+     $            AP( KNC ) = REAL( AP( KNC ) )
+            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 / REAL( AP( KC ) )
+                  CALL CHPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+     $                       AP( KC+N-K+1 ) )
+*
+*                 Store L(k) in column K
+*
+                  CALL CSSCAL( 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) )'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D = SLAPY2( REAL( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ),
+     $                AIMAG( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ) )
+                  D11 = REAL( AP( K+1+K*( 2*N-K-1 ) / 2 ) ) / D
+                  D22 = REAL( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D
+                  D = TT / D
+*
+                  DO 100 J = K + 2, N
+                     WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21*
+     $                    AP( J+K*( 2*N-K-1 ) / 2 ) )
+                     WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
+     $                      CONJG( D21 )*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 )*CONJG( WK ) - AP( I+K*( 2*N-K-1 ) / 2 )*
+     $                     CONJG( WKP1 )
+   90                CONTINUE
+                     AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
+                     AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
+                     AP( J+( J-1 )*( 2*N-J ) / 2 )
+     $                  = CMPLX( REAL( AP( J+( J-1 )*( 2*N-J ) / 2 ) ),
+     $                  0.0E+0 )
+  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 CHPTRF
+*
+      END
diff --git a/SRC/chptri.f b/SRC/chptri.f
new file mode 100644
index 00000000..298d6533
--- /dev/null
+++ b/SRC/chptri.f
@@ -0,0 +1,343 @@
+      SUBROUTINE CHPTRI( UPLO, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPTRI computes the inverse of a complex Hermitian indefinite matrix
+*  A in packed storage using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by CHPTRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by CHPTRF,
+*          stored as a packed triangular matrix.
+*
+*          On exit, if INFO = 0, the (Hermitian) inverse of the original
+*          matrix, stored as a packed triangular matrix. The j-th column
+*          of inv(A) is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+*          if UPLO = 'L',
+*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CHPTRF.
+*
+*  WORK    (workspace) COMPLEX 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 ..
+      REAL               ONE
+      COMPLEX            CONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+      REAL               AK, AKP1, D, T
+      COMPLEX            AKKP1, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CHPMV, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, REAL
+*     ..
+*     .. 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( 'CHPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         KP = N*( N+1 ) / 2
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP - INFO
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         KP = 1
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP + N - INFO + 1
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         KCNEXT = KC + K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC+K-1 ) = ONE / REAL( AP( KC+K-1 ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL CCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL CHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
+     $                     AP( KC ), 1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        REAL( CDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+K-1 ) )
+            AK = REAL( AP( KC+K-1 ) ) / T
+            AKP1 = REAL( AP( KCNEXT+K ) ) / T
+            AKKP1 = AP( KCNEXT+K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KC+K-1 ) = AKP1 / D
+            AP( KCNEXT+K ) = AK / D
+            AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL CCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL CHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
+     $                     AP( KC ), 1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        REAL( CDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
+               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+     $                            CDOTC( K-1, AP( KC ), 1, AP( KCNEXT ),
+     $                            1 )
+               CALL CCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+               CALL CHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
+     $                     AP( KCNEXT ), 1 )
+               AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+     $                          REAL( CDOTC( K-1, WORK, 1, AP( KCNEXT ),
+     $                          1 ) )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT + K + 1
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            KPC = ( KP-1 )*KP / 2 + 1
+            CALL CSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+            KX = KPC + KP - 1
+            DO 40 J = KP + 1, K - 1
+               KX = KX + J - 1
+               TEMP = CONJG( AP( KC+J-1 ) )
+               AP( KC+J-1 ) = CONJG( AP( KX ) )
+               AP( KX ) = TEMP
+   40       CONTINUE
+            AP( KC+KP-1 ) = CONJG( AP( KC+KP-1 ) )
+            TEMP = AP( KC+K-1 )
+            AP( KC+K-1 ) = AP( KPC+KP-1 )
+            AP( KPC+KP-1 ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC+K+K-1 )
+               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+               AP( KC+K+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         KC = KCNEXT
+         GO TO 30
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         NPP = N*( N+1 ) / 2
+         K = N
+         KC = NPP
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         KCNEXT = KC - ( N-K+2 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC ) = ONE / REAL( AP( KC ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL CCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL CHPMV( UPLO, N-K, -CONE, AP( KC+N-K+1 ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - REAL( CDOTC( N-K, WORK, 1,
+     $                    AP( KC+1 ), 1 ) )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+1 ) )
+            AK = REAL( AP( KCNEXT ) ) / T
+            AKP1 = REAL( AP( KC ) ) / T
+            AKKP1 = AP( KCNEXT+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KCNEXT ) = AKP1 / D
+            AP( KC ) = AK / D
+            AP( KCNEXT+1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL CCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL CHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ), WORK,
+     $                     1, ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - REAL( CDOTC( N-K, WORK, 1,
+     $                    AP( KC+1 ), 1 ) )
+               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+     $                          CDOTC( N-K, AP( KC+1 ), 1,
+     $                          AP( KCNEXT+2 ), 1 )
+               CALL CCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+               CALL CHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ), WORK,
+     $                     1, ZERO, AP( KCNEXT+2 ), 1 )
+               AP( KCNEXT ) = AP( KCNEXT ) -
+     $                        REAL( CDOTC( N-K, WORK, 1, AP( KCNEXT+2 ),
+     $                        1 ) )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT - ( N-K+3 )
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+            IF( KP.LT.N )
+     $         CALL CSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+            KX = KC + KP - K
+            DO 70 J = K + 1, KP - 1
+               KX = KX + N - J + 1
+               TEMP = CONJG( AP( KC+J-K ) )
+               AP( KC+J-K ) = CONJG( AP( KX ) )
+               AP( KX ) = TEMP
+   70       CONTINUE
+            AP( KC+KP-K ) = CONJG( AP( KC+KP-K ) )
+            TEMP = AP( KC )
+            AP( KC ) = AP( KPC )
+            AP( KPC ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC-N+K-1 )
+               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+               AP( KC-N+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         KC = KCNEXT
+         GO TO 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHPTRI
+*
+      END
diff --git a/SRC/chptrs.f b/SRC/chptrs.f
new file mode 100644
index 00000000..9767860a
--- /dev/null
+++ b/SRC/chptrs.f
@@ -0,0 +1,401 @@
+      SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHPTRS solves a system of linear equations A*X = B with a complex
+*  Hermitian matrix A stored in packed format using the factorization
+*  A = U*D*U**H or A = L*D*L**H computed by CHPTRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CHPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CHPTRF.
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KP
+      REAL               S
+      COMPLEX            AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHPTRS', -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
+         KC = N*( N+1 ) / 2 + 1
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         KC = KC - K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            S = REAL( ONE ) / REAL( AP( KC+K-1 ) )
+            CALL CSSCAL( NRHS, S, 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 CSWAP( 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 CGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL CGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+     $                  B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+K-2 )
+            AKM1 = AP( KC-1 ) / AKM1K
+            AK = AP( KC+K-1 ) / CONJG( AKM1K )
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / CONJG( AKM1K )
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            KC = KC - K + 1
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.GT.1 ) THEN
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + K
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            IF( K.GT.1 ) THEN
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + 2*K + 1
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+     $                     LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            S = REAL( ONE ) / REAL( AP( KC ) )
+            CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
+            KC = KC + N - K + 1
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL CSWAP( 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 CGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL CGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+     $                     B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+1 )
+            AKM1 = AP( KC ) / CONJG( AKM1K )
+            AK = AP( KC+N-K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / CONJG( AKM1K )
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            KC = KC + 2*( N-K ) + 1
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         KC = KC - ( N-K+1 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N ) THEN
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CLACGV( NRHS, B( K, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, AP( KC-( N-K ) ), 1, ONE,
+     $                     B( K-1, 1 ), LDB )
+               CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC - ( N-K+2 )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CHPTRS
+*
+      END
diff --git a/SRC/chsein.f b/SRC/chsein.f
new file mode 100644
index 00000000..7d93c686
--- /dev/null
+++ b/SRC/chsein.f
@@ -0,0 +1,350 @@
+      SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL,
+     $                   LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL,
+     $                   IFAILR, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EIGSRC, INITV, SIDE
+      INTEGER            INFO, LDH, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IFAILL( * ), IFAILR( * )
+      REAL               RWORK( * )
+      COMPLEX            H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CHSEIN uses inverse iteration to find specified right and/or left
+*  eigenvectors of a complex upper Hessenberg matrix H.
+*
+*  The right eigenvector x and the left eigenvector y of the matrix H
+*  corresponding to an eigenvalue w are defined by:
+*
+*               H * x = w * x,     y**h * H = w * y**h
+*
+*  where y**h denotes the conjugate transpose of the vector y.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R': compute right eigenvectors only;
+*          = 'L': compute left eigenvectors only;
+*          = 'B': compute both right and left eigenvectors.
+*
+*  EIGSRC  (input) CHARACTER*1
+*          Specifies the source of eigenvalues supplied in W:
+*          = 'Q': the eigenvalues were found using CHSEQR; thus, if
+*                 H has zero subdiagonal elements, and so is
+*                 block-triangular, then the j-th eigenvalue can be
+*                 assumed to be an eigenvalue of the block containing
+*                 the j-th row/column.  This property allows CHSEIN to
+*                 perform inverse iteration on just one diagonal block.
+*          = 'N': no assumptions are made on the correspondence
+*                 between eigenvalues and diagonal blocks.  In this
+*                 case, CHSEIN must always perform inverse iteration
+*                 using the whole matrix H.
+*
+*  INITV   (input) CHARACTER*1
+*          = 'N': no initial vectors are supplied;
+*          = 'U': user-supplied initial vectors are stored in the arrays
+*                 VL and/or VR.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          Specifies the eigenvectors to be computed. To select the
+*          eigenvector corresponding to the eigenvalue W(j),
+*          SELECT(j) must be set to .TRUE..
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) COMPLEX array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  W       (input/output) COMPLEX array, dimension (N)
+*          On entry, the eigenvalues of H.
+*          On exit, the real parts of W may have been altered since
+*          close eigenvalues are perturbed slightly in searching for
+*          independent eigenvectors.
+*
+*  VL      (input/output) COMPLEX array, dimension (LDVL,MM)
+*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
+*          contain starting vectors for the inverse iteration for the
+*          left eigenvectors; the starting vector for each eigenvector
+*          must be in the same column in which the eigenvector will be
+*          stored.
+*          On exit, if SIDE = 'L' or 'B', the left eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VL, in the same order as their eigenvalues.
+*          If SIDE = 'R', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
+*
+*  VR      (input/output) COMPLEX array, dimension (LDVR,MM)
+*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
+*          contain starting vectors for the inverse iteration for the
+*          right eigenvectors; the starting vector for each eigenvector
+*          must be in the same column in which the eigenvector will be
+*          stored.
+*          On exit, if SIDE = 'R' or 'B', the right eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VR, in the same order as their eigenvalues.
+*          If SIDE = 'L', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
+*
+*  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 required to
+*          store the eigenvectors (= the number of .TRUE. elements in
+*          SELECT).
+*
+*  WORK    (workspace) COMPLEX array, dimension (N*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  IFAILL  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
+*          eigenvector in the i-th column of VL (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
+*          eigenvector converged satisfactorily.
+*          If SIDE = 'R', IFAILL is not referenced.
+*
+*  IFAILR  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
+*          eigenvector in the i-th column of VR (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
+*          eigenvector converged satisfactorily.
+*          If SIDE = 'L', IFAILR is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, i is the number of eigenvectors which
+*                failed to converge; see IFAILL and IFAILR for further
+*                details.
+*
+*  Further Details
+*  ===============
+*
+*  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 ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+      REAL               RZERO
+      PARAMETER          ( RZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            BOTHV, FROMQR, LEFTV, NOINIT, RIGHTV
+      INTEGER            I, IINFO, K, KL, KLN, KR, KS, LDWORK
+      REAL               EPS3, HNORM, SMLNUM, ULP, UNFL
+      COMPLEX            CDUM, WK
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHS, SLAMCH
+      EXTERNAL           LSAME, CLANHS, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLAEIN, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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
+*
+      FROMQR = LSAME( EIGSRC, 'Q' )
+*
+      NOINIT = LSAME( INITV, 'N' )
+*
+*     Set M to the number of columns required to store the selected
+*     eigenvectors.
+*
+      M = 0
+      DO 10 K = 1, N
+         IF( SELECT( K ) )
+     $      M = M + 1
+   10 CONTINUE
+*
+      INFO = 0
+      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -1
+      ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+         INFO = -12
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CHSEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set machine-dependent constants.
+*
+      UNFL = SLAMCH( 'Safe minimum' )
+      ULP = SLAMCH( 'Precision' )
+      SMLNUM = UNFL*( N / ULP )
+*
+      LDWORK = N
+*
+      KL = 1
+      KLN = 0
+      IF( FROMQR ) THEN
+         KR = 0
+      ELSE
+         KR = N
+      END IF
+      KS = 1
+*
+      DO 100 K = 1, N
+         IF( SELECT( K ) ) THEN
+*
+*           Compute eigenvector(s) corresponding to W(K).
+*
+            IF( FROMQR ) THEN
+*
+*              If affiliation of eigenvalues is known, check whether
+*              the matrix splits.
+*
+*              Determine KL and KR such that 1 <= KL <= K <= KR <= N
+*              and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
+*              KR = N).
+*
+*              Then inverse iteration can be performed with the
+*              submatrix H(KL:N,KL:N) for a left eigenvector, and with
+*              the submatrix H(1:KR,1:KR) for a right eigenvector.
+*
+               DO 20 I = K, KL + 1, -1
+                  IF( H( I, I-1 ).EQ.ZERO )
+     $               GO TO 30
+   20          CONTINUE
+   30          CONTINUE
+               KL = I
+               IF( K.GT.KR ) THEN
+                  DO 40 I = K, N - 1
+                     IF( H( I+1, I ).EQ.ZERO )
+     $                  GO TO 50
+   40             CONTINUE
+   50             CONTINUE
+                  KR = I
+               END IF
+            END IF
+*
+            IF( KL.NE.KLN ) THEN
+               KLN = KL
+*
+*              Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
+*              has not ben computed before.
+*
+               HNORM = CLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK )
+               IF( HNORM.GT.RZERO ) THEN
+                  EPS3 = HNORM*ULP
+               ELSE
+                  EPS3 = SMLNUM
+               END IF
+            END IF
+*
+*           Perturb eigenvalue if it is close to any previous
+*           selected eigenvalues affiliated to the submatrix
+*           H(KL:KR,KL:KR). Close roots are modified by EPS3.
+*
+            WK = W( K )
+   60       CONTINUE
+            DO 70 I = K - 1, KL, -1
+               IF( SELECT( I ) .AND. CABS1( W( I )-WK ).LT.EPS3 ) THEN
+                  WK = WK + EPS3
+                  GO TO 60
+               END IF
+   70       CONTINUE
+            W( K ) = WK
+*
+            IF( LEFTV ) THEN
+*
+*              Compute left eigenvector.
+*
+               CALL CLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
+     $                      WK, VL( KL, KS ), WORK, LDWORK, RWORK, EPS3,
+     $                      SMLNUM, IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  INFO = INFO + 1
+                  IFAILL( KS ) = K
+               ELSE
+                  IFAILL( KS ) = 0
+               END IF
+               DO 80 I = 1, KL - 1
+                  VL( I, KS ) = ZERO
+   80          CONTINUE
+            END IF
+            IF( RIGHTV ) THEN
+*
+*              Compute right eigenvector.
+*
+               CALL CLAEIN( .TRUE., NOINIT, KR, H, LDH, WK, VR( 1, KS ),
+     $                      WORK, LDWORK, RWORK, EPS3, SMLNUM, IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  INFO = INFO + 1
+                  IFAILR( KS ) = K
+               ELSE
+                  IFAILR( KS ) = 0
+               END IF
+               DO 90 I = KR + 1, N
+                  VR( I, KS ) = ZERO
+   90          CONTINUE
+            END IF
+            KS = KS + 1
+         END IF
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of CHSEIN
+*
+      END
diff --git a/SRC/chseqr.f b/SRC/chseqr.f
new file mode 100644
index 00000000..42977fd2
--- /dev/null
+++ b/SRC/chseqr.f
@@ -0,0 +1,395 @@
+      SUBROUTINE CHSEQR( 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            H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*     Purpose
+*     =======
+*
+*     CHSEQR 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 CGEBAL, and then passed to CGEHRD
+*           when the matrix output by CGEBAL 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 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 CHSEQR, 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 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 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 CUNGHR
+*           after the call to CGEHRD 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 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 CHSEQR does a workspace query.
+*           In this case, CHSEQR 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, CHSEQR 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,'CHSEQR',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 CLAHQR vs CLAQR0 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
+*                       CLAHQR 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
+*     .    CLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== NL allocates some local workspace to help small matrices
+*     .    through a rare CLAHQR 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               RZERO
+      PARAMETER          ( RZERO = 0.0e0 )
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            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           CCOPY, CLACPY, CLAHQR, CLAQR0, CLASET, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX, MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Decode and check the input parameters. ====
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+      WORK( 1 ) = CMPLX( REAL( 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( 'CHSEQR', -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 CLAQR0( 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 ) = CMPLX( MAX( REAL( WORK( 1 ) ), REAL( MAX( 1,
+     $               N ) ) ), RZERO )
+         RETURN
+*
+      ELSE
+*
+*        ==== copy eigenvalues isolated by CGEBAL ====
+*
+         IF( ILO.GT.1 )
+     $      CALL CCOPY( ILO-1, H, LDH+1, W, 1 )
+         IF( IHI.LT.N )
+     $      CALL CCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
+*
+*        ==== Initialize Z, if requested ====
+*
+         IF( INITZ )
+     $      CALL CLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
+*
+*        ==== Quick return if possible ====
+*
+         IF( ILO.EQ.IHI ) THEN
+            W( ILO ) = H( ILO, ILO )
+            RETURN
+         END IF
+*
+*        ==== CLAHQR/CLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 1, 'CHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
+     $          IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== CLAQR0 for big matrices; CLAHQR for small ones ====
+*
+         IF( N.GT.NMIN ) THEN
+            CALL CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
+     $                   Z, LDZ, WORK, LWORK, INFO )
+         ELSE
+*
+*           ==== Small matrix ====
+*
+            CALL CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
+     $                   Z, LDZ, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+*
+*              ==== A rare CLAHQR failure!  CLAQR0 sometimes succeeds
+*              .    when CLAHQR fails. ====
+*
+               KBOT = INFO
+*
+               IF( N.GE.NL ) THEN
+*
+*                 ==== Larger matrices have enough subdiagonal scratch
+*                 .    space to call CLAQR0 directly. ====
+*
+                  CALL CLAQR0( 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 CLAQR0.  Hence,
+*                 .    tiny matrices must be copied into a larger
+*                 .    array before calling CLAQR0. ====
+*
+                  CALL CLACPY( 'A', N, N, H, LDH, HL, NL )
+                  HL( N+1, N ) = ZERO
+                  CALL CLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+     $                         NL )
+                  CALL CLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
+     $                         ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+                  IF( WANTT .OR. INFO.NE.0 )
+     $               CALL CLACPY( '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 CLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
+*
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+*
+         WORK( 1 ) = CMPLX( MAX( REAL( MAX( 1, N ) ),
+     $               REAL( WORK( 1 ) ) ), RZERO )
+      END IF
+*
+*     ==== End of CHSEQR ====
+*
+      END
diff --git a/SRC/clabrd.f b/SRC/clabrd.f
new file mode 100644
index 00000000..fd656f98
--- /dev/null
+++ b/SRC/clabrd.f
@@ -0,0 +1,328 @@
+      SUBROUTINE CLABRD( 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 ..
+      REAL               D( * ), E( * )
+      COMPLEX            A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
+     $                   Y( LDY, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLABRD 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 CGEBRD
+*
+*  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 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) REAL array, dimension (NB)
+*          The diagonal elements of the first NB rows and columns of
+*          the reduced matrix.  D(i) = A(i,i).
+*
+*  E       (output) REAL array, dimension (NB)
+*          The off-diagonal elements of the first NB rows and columns of
+*          the reduced matrix.
+*
+*  TAUQ    (output) COMPLEX array dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q. See Further Details.
+*
+*  TAUP    (output) COMPLEX array, dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix P. See Further Details.
+*
+*  X       (output) COMPLEX 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 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CLACGV, CLARFG, CSCAL
+*     ..
+*     .. 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 CLACGV( I-1, Y( I, 1 ), LDY )
+            CALL CGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
+            CALL CLACGV( I-1, Y( I, 1 ), LDY )
+            CALL CGEMV( '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 CLARFG( 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 CGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
+     $                     A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
+     $                     Y( I+1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
+     $                     A( I, 1 ), LDA, A( I, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
+     $                     X( I, 1 ), LDX, A( I, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
+     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
+     $                     Y( I+1, I ), 1 )
+               CALL CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+*
+*              Update A(i,i+1:n)
+*
+               CALL CLACGV( N-I, A( I, I+1 ), LDA )
+               CALL CLACGV( I, A( I, 1 ), LDA )
+               CALL CGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
+     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
+               CALL CLACGV( I, A( I, 1 ), LDA )
+               CALL CLACGV( I-1, X( I, 1 ), LDX )
+               CALL CGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
+     $                     A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
+     $                     A( I, I+1 ), LDA )
+               CALL CLACGV( I-1, X( I, 1 ), LDX )
+*
+*              Generate reflection P(i) to annihilate A(i,i+2:n)
+*
+               ALPHA = A( I, I+1 )
+               CALL CLARFG( 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 CGEMV( '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 CGEMV( 'Conjugate transpose', N-I, I, ONE,
+     $                     Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
+     $                     X( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL CGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+               CALL CLACGV( 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 CLACGV( N-I+1, A( I, I ), LDA )
+            CALL CLACGV( I-1, A( I, 1 ), LDA )
+            CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
+     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
+            CALL CLACGV( I-1, A( I, 1 ), LDA )
+            CALL CLACGV( I-1, X( I, 1 ), LDX )
+            CALL CGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
+     $                  A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
+     $                  LDA )
+            CALL CLACGV( I-1, X( I, 1 ), LDX )
+*
+*           Generate reflection P(i) to annihilate A(i,i+1:n)
+*
+            ALPHA = A( I, I )
+            CALL CLARFG( 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 CGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
+     $                     Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
+     $                     X( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL CGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+               CALL CLACGV( N-I+1, A( I, I ), LDA )
+*
+*              Update A(i+1:m,i)
+*
+               CALL CLACGV( I-1, Y( I, 1 ), LDY )
+               CALL CGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
+               CALL CLACGV( I-1, Y( I, 1 ), LDY )
+               CALL CGEMV( '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 CLARFG( 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 CGEMV( '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 CGEMV( 'Conjugate transpose', M-I, I-1, ONE,
+     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', M-I, I, ONE,
+     $                     X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', I, N-I, -ONE,
+     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
+     $                     Y( I+1, I ), 1 )
+               CALL CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+            ELSE
+               CALL CLACGV( N-I+1, A( I, I ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of CLABRD
+*
+      END
diff --git a/SRC/clacgv.f b/SRC/clacgv.f
new file mode 100644
index 00000000..342d1790
--- /dev/null
+++ b/SRC/clacgv.f
@@ -0,0 +1,60 @@
+      SUBROUTINE CLACGV( 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            X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACGV conjugates a complex vector of length N.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The length of the vector X.  N >= 0.
+*
+*  X       (input/output) COMPLEX 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          CONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( INCX.EQ.1 ) THEN
+         DO 10 I = 1, N
+            X( I ) = CONJG( X( I ) )
+   10    CONTINUE
+      ELSE
+         IOFF = 1
+         IF( INCX.LT.0 )
+     $      IOFF = 1 - ( N-1 )*INCX
+         DO 20 I = 1, N
+            X( IOFF ) = CONJG( X( IOFF ) )
+            IOFF = IOFF + INCX
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of CLACGV
+*
+      END
diff --git a/SRC/clacn2.f b/SRC/clacn2.f
new file mode 100755
index 00000000..319833ba
--- /dev/null
+++ b/SRC/clacn2.f
@@ -0,0 +1,221 @@
+      SUBROUTINE CLACN2( 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
+      REAL               EST
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISAVE( 3 )
+      COMPLEX            V( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACN2 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 array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) COMPLEX 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 CLACN2 must be
+*         re-called with all the other parameters unchanged.
+*
+*  EST    (input/output) REAL
+*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
+*         unchanged from the previous call to CLACN2.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to CLACN2, 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 CLACN2, KASE will again be 0.
+*
+*  ISAVE  (input/output) INTEGER array, dimension (3)
+*         ISAVE is used to save variables between calls to SLACN2
+*
+*  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 CLACON, which uses the array ISAVE
+*  in place of a SAVE statement, as follows:
+*
+*     CLACON     CLACN2
+*      JUMP     ISAVE(1)
+*      J        ISAVE(2)
+*      ITER     ISAVE(3)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER              ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      REAL                 ONE,         TWO
+      PARAMETER          ( ONE = 1.0E0, TWO = 2.0E0 )
+      COMPLEX              CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                            CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, JLAST
+      REAL               ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            ICMAX1
+      REAL               SCSUM1, SLAMCH
+      EXTERNAL           ICMAX1, SCSUM1, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = CMPLX( ONE / REAL( 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 = SCSUM1( N, X, 1 )
+*
+      DO 30 I = 1, N
+         ABSXI = ABS( X( I ) )
+         IF( ABSXI.GT.SAFMIN ) THEN
+            X( I ) = CMPLX( REAL( X( I ) ) / ABSXI,
+     $               AIMAG( 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 ) = ICMAX1( 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 CCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = SCSUM1( 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 ) = CMPLX( REAL( X( I ) ) / ABSXI,
+     $               AIMAG( 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 ) = ICMAX1( 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 ) = CMPLX( ALTSGN*( ONE + REAL( I-1 ) / REAL( 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*( SCSUM1( N, X, 1 ) / REAL( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL CCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  130 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of CLACN2
+*
+      END
diff --git a/SRC/clacon.f b/SRC/clacon.f
new file mode 100644
index 00000000..2228701d
--- /dev/null
+++ b/SRC/clacon.f
@@ -0,0 +1,212 @@
+      SUBROUTINE CLACON( 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
+      REAL               EST
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            V( N ), X( N )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACON 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 array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) COMPLEX 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 CLACON must be
+*         re-called with all the other parameters unchanged.
+*
+*  EST    (input/output) REAL
+*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
+*         unchanged from the previous call to CLACON.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to CLACON, 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 CLACON, 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 )
+      REAL               ONE, TWO
+      PARAMETER          ( ONE = 1.0E0, TWO = 2.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITER, J, JLAST, JUMP
+      REAL               ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            ICMAX1
+      REAL               SCSUM1, SLAMCH
+      EXTERNAL           ICMAX1, SCSUM1, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, REAL
+*     ..
+*     .. Save statement ..
+      SAVE
+*     ..
+*     .. Executable Statements ..
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = CMPLX( ONE / REAL( 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 = SCSUM1( N, X, 1 )
+*
+      DO 30 I = 1, N
+         ABSXI = ABS( X( I ) )
+         IF( ABSXI.GT.SAFMIN ) THEN
+            X( I ) = CMPLX( REAL( X( I ) ) / ABSXI,
+     $               AIMAG( 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 = ICMAX1( 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 CCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = SCSUM1( 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 ) = CMPLX( REAL( X( I ) ) / ABSXI,
+     $               AIMAG( 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 = ICMAX1( 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 ) = CMPLX( ALTSGN*( ONE+REAL( I-1 ) / REAL( 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*( SCSUM1( N, X, 1 ) / REAL( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL CCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  130 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of CLACON
+*
+      END
diff --git a/SRC/clacp2.f b/SRC/clacp2.f
new file mode 100644
index 00000000..0cacd194
--- /dev/null
+++ b/SRC/clacp2.f
@@ -0,0 +1,91 @@
+      SUBROUTINE CLACP2( 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 ..
+      REAL               A( LDA, * )
+      COMPLEX            B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACP2 copies all or part of a real two-dimensional matrix A to a
+*  complex 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) REAL 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 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 CLACP2
+*
+      END
diff --git a/SRC/clacpy.f b/SRC/clacpy.f
new file mode 100644
index 00000000..4af4a78f
--- /dev/null
+++ b/SRC/clacpy.f
@@ -0,0 +1,90 @@
+      SUBROUTINE CLACPY( 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            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACPY 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 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 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 CLACPY
+*
+      END
diff --git a/SRC/clacrm.f b/SRC/clacrm.f
new file mode 100644
index 00000000..804f97f1
--- /dev/null
+++ b/SRC/clacrm.f
@@ -0,0 +1,110 @@
+      SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDB, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), RWORK( * )
+      COMPLEX            A( LDA, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACRM performs a very simple matrix-matrix multiplication:
+*           C := A * B,
+*  where A is M by N and complex; B is N by N and real;
+*  C is M by N and complex.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A and of the matrix C.
+*          M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns and rows of the matrix B and
+*          the number of columns of the matrix C.
+*          N >= 0.
+*
+*  A       (input) COMPLEX array, dimension (LDA, N)
+*          A contains the M by N matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >=max(1,M).
+*
+*  B       (input) REAL array, dimension (LDB, N)
+*          B contains the N by N matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >=max(1,N).
+*
+*  C       (input) COMPLEX array, dimension (LDC, N)
+*          C contains the M by N matrix C.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >=max(1,N).
+*
+*  RWORK   (workspace) REAL array, dimension (2*M*N)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, REAL
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+     $   RETURN
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, M
+            RWORK( ( J-1 )*M+I ) = REAL( A( I, J ) )
+   10    CONTINUE
+   20 CONTINUE
+*
+      L = M*N + 1
+      CALL SGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
+     $            RWORK( L ), M )
+      DO 40 J = 1, N
+         DO 30 I = 1, M
+            C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
+   30    CONTINUE
+   40 CONTINUE
+*
+      DO 60 J = 1, N
+         DO 50 I = 1, M
+            RWORK( ( J-1 )*M+I ) = AIMAG( A( I, J ) )
+   50    CONTINUE
+   60 CONTINUE
+      CALL SGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
+     $            RWORK( L ), M )
+      DO 80 J = 1, N
+         DO 70 I = 1, M
+            C( I, J ) = CMPLX( REAL( C( I, J ) ),
+     $                  RWORK( L+( J-1 )*M+I-1 ) )
+   70    CONTINUE
+   80 CONTINUE
+*
+      RETURN
+*
+*     End of CLACRM
+*
+      END
diff --git a/SRC/clacrt.f b/SRC/clacrt.f
new file mode 100644
index 00000000..71f6203d
--- /dev/null
+++ b/SRC/clacrt.f
@@ -0,0 +1,90 @@
+      SUBROUTINE CLACRT( 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
+      COMPLEX            C, S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            CX( * ), CY( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLACRT performs the operation
+*
+*     (  c  s )( x )  ==> ( x )
+*     ( -s  c )( y )      ( y )
+*
+*  where c and s are complex and the vectors x and y are complex.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vectors CX and CY.
+*
+*  CX      (input/output) COMPLEX 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 CX.  INCX <> 0.
+*
+*  CY      (input/output) COMPLEX array, dimension (N)
+*          On input, the vector y.
+*          On output, CY is overwritten with -s*x + c*y.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive values of CY.  INCY <> 0.
+*
+*  C       (input) COMPLEX
+*  S       (input) COMPLEX
+*          C and S define the matrix
+*             [  C   S  ].
+*             [ -S   C  ]
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IX, IY
+      COMPLEX            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/cladiv.f b/SRC/cladiv.f
new file mode 100644
index 00000000..9819faa5
--- /dev/null
+++ b/SRC/cladiv.f
@@ -0,0 +1,46 @@
+      COMPLEX FUNCTION CLADIV( X, Y )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      COMPLEX            X, Y
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLADIV := 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
+*  Y       (input) COMPLEX
+*          The complex scalars X and Y.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      REAL               ZI, ZR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
+     $             ZI )
+      CLADIV = CMPLX( ZR, ZI )
+*
+      RETURN
+*
+*     End of CLADIV
+*
+      END
diff --git a/SRC/claed0.f b/SRC/claed0.f
new file mode 100644
index 00000000..f3c609c8
--- /dev/null
+++ b/SRC/claed0.f
@@ -0,0 +1,288 @@
+      SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDQ, LDQS, N, QSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), RWORK( * )
+      COMPLEX            Q( LDQ, * ), QSTORE( LDQS, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Using the divide and conquer method, CLAED0 computes all eigenvalues
+*  of a symmetric tridiagonal matrix which is one diagonal block of
+*  those from reducing a dense or band Hermitian matrix and
+*  corresponding eigenvectors of the dense or band matrix.
+*
+*  Arguments
+*  =========
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the unitary matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, the diagonal elements of the tridiagonal matrix.
+*         On exit, the eigenvalues in ascending order.
+*
+*  E      (input/output) REAL array, dimension (N-1)
+*         On entry, the off-diagonal elements of the tridiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  Q      (input/output) COMPLEX array, dimension (LDQ,N)
+*         On entry, Q must contain an QSIZ x N matrix whose columns
+*         unitarily orthonormal. It is a part of the unitary matrix
+*         that reduces the full dense Hermitian matrix to a
+*         (reducible) symmetric tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  IWORK  (workspace) INTEGER array,
+*         the dimension of IWORK must be at least
+*                      6 + 6*N + 5*N*lg N
+*                      ( lg( N ) = smallest integer k
+*                                  such that 2^k >= N )
+*
+*  RWORK  (workspace) REAL array,
+*                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)
+*                        ( lg( N ) = smallest integer k
+*                                    such that 2^k >= N )
+*
+*  QSTORE (workspace) COMPLEX array, dimension (LDQS, N)
+*         Used to store parts of
+*         the eigenvector matrix when the updating matrix multiplies
+*         take place.
+*
+*  LDQS   (input) INTEGER
+*         The leading dimension of the array QSTORE.
+*         LDQS >= max(1,N).
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  =====================================================================
+*
+*  Warning:      N could be as big as QSIZ!
+*
+*     .. Parameters ..
+      REAL               TWO
+      PARAMETER          ( TWO = 2.E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
+     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
+     $                   J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
+     $                   SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
+      REAL               TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACRM, CLAED7, SCOPY, SSTEQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+*     IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
+*        INFO = -1
+*     ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
+*    $        THEN
+      IF( QSIZ.LT.MAX( 0, N ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLAED0', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      SMLSIZ = ILAENV( 9, 'CLAED0', ' ', 0, 0, 0, 0 )
+*
+*     Determine the size and placement of the submatrices, and save in
+*     the leading elements of IWORK.
+*
+      IWORK( 1 ) = N
+      SUBPBS = 1
+      TLVLS = 0
+   10 CONTINUE
+      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
+         DO 20 J = SUBPBS, 1, -1
+            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
+            IWORK( 2*J-1 ) = IWORK( J ) / 2
+   20    CONTINUE
+         TLVLS = TLVLS + 1
+         SUBPBS = 2*SUBPBS
+         GO TO 10
+      END IF
+      DO 30 J = 2, SUBPBS
+         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
+   30 CONTINUE
+*
+*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
+*     using rank-1 modifications (cuts).
+*
+      SPM1 = SUBPBS - 1
+      DO 40 I = 1, SPM1
+         SUBMAT = IWORK( I ) + 1
+         SMM1 = SUBMAT - 1
+         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
+         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
+   40 CONTINUE
+*
+      INDXQ = 4*N + 3
+*
+*     Set up workspaces for eigenvalues only/accumulate new vectors
+*     routine
+*
+      TEMP = LOG( REAL( N ) ) / LOG( TWO )
+      LGN = INT( TEMP )
+      IF( 2**LGN.LT.N )
+     $   LGN = LGN + 1
+      IF( 2**LGN.LT.N )
+     $   LGN = LGN + 1
+      IPRMPT = INDXQ + N + 1
+      IPERM = IPRMPT + N*LGN
+      IQPTR = IPERM + N*LGN
+      IGIVPT = IQPTR + N + 2
+      IGIVCL = IGIVPT + N*LGN
+*
+      IGIVNM = 1
+      IQ = IGIVNM + 2*N*LGN
+      IWREM = IQ + N**2 + 1
+*     Initialize pointers
+      DO 50 I = 0, SUBPBS
+         IWORK( IPRMPT+I ) = 1
+         IWORK( IGIVPT+I ) = 1
+   50 CONTINUE
+      IWORK( IQPTR ) = 1
+*
+*     Solve each submatrix eigenproblem at the bottom of the divide and
+*     conquer tree.
+*
+      CURR = 0
+      DO 70 I = 0, SPM1
+         IF( I.EQ.0 ) THEN
+            SUBMAT = 1
+            MATSIZ = IWORK( 1 )
+         ELSE
+            SUBMAT = IWORK( I ) + 1
+            MATSIZ = IWORK( I+1 ) - IWORK( I )
+         END IF
+         LL = IQ - 1 + IWORK( IQPTR+CURR )
+         CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+     $                RWORK( LL ), MATSIZ, RWORK, INFO )
+         CALL CLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
+     $                MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
+     $                RWORK( IWREM ) )
+         IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
+         CURR = CURR + 1
+         IF( INFO.GT.0 ) THEN
+            INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+            RETURN
+         END IF
+         K = 1
+         DO 60 J = SUBMAT, IWORK( I+1 )
+            IWORK( INDXQ+J ) = K
+            K = K + 1
+   60    CONTINUE
+   70 CONTINUE
+*
+*     Successively merge eigensystems of adjacent submatrices
+*     into eigensystem for the corresponding larger matrix.
+*
+*     while ( SUBPBS > 1 )
+*
+      CURLVL = 1
+   80 CONTINUE
+      IF( SUBPBS.GT.1 ) THEN
+         SPM2 = SUBPBS - 2
+         DO 90 I = 0, SPM2, 2
+            IF( I.EQ.0 ) THEN
+               SUBMAT = 1
+               MATSIZ = IWORK( 2 )
+               MSD2 = IWORK( 1 )
+               CURPRB = 0
+            ELSE
+               SUBMAT = IWORK( I ) + 1
+               MATSIZ = IWORK( I+2 ) - IWORK( I )
+               MSD2 = MATSIZ / 2
+               CURPRB = CURPRB + 1
+            END IF
+*
+*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
+*     into an eigensystem of size MATSIZ.  CLAED7 handles the case
+*     when the eigenvectors of a full or band Hermitian matrix (which
+*     was reduced to tridiagonal form) are desired.
+*
+*     I am free to use Q as a valuable working space until Loop 150.
+*
+            CALL CLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
+     $                   D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
+     $                   E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
+     $                   RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
+     $                   IWORK( IPERM ), IWORK( IGIVPT ),
+     $                   IWORK( IGIVCL ), RWORK( IGIVNM ),
+     $                   Q( 1, SUBMAT ), RWORK( IWREM ),
+     $                   IWORK( SUBPBS+1 ), INFO )
+            IF( INFO.GT.0 ) THEN
+               INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+               RETURN
+            END IF
+            IWORK( I / 2+1 ) = IWORK( I+2 )
+   90    CONTINUE
+         SUBPBS = SUBPBS / 2
+         CURLVL = CURLVL + 1
+         GO TO 80
+      END IF
+*
+*     end while
+*
+*     Re-merge the eigenvalues/vectors which were deflated at the final
+*     merge step.
+*
+      DO 100 I = 1, N
+         J = IWORK( INDXQ+I )
+         RWORK( I ) = D( J )
+         CALL CCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
+  100 CONTINUE
+      CALL SCOPY( N, RWORK, 1, D, 1 )
+*
+      RETURN
+*
+*     End of CLAED0
+*
+      END
diff --git a/SRC/claed7.f b/SRC/claed7.f
new file mode 100644
index 00000000..819fb023
--- /dev/null
+++ b/SRC/claed7.f
@@ -0,0 +1,264 @@
+      SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
+     $                   LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
+     $                   GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
+     $                   TLVLS
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
+     $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
+      REAL               D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
+      COMPLEX            Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAED7 computes the updated eigensystem of a diagonal
+*  matrix after modification by a rank-one symmetric matrix. This
+*  routine is used only for the eigenproblem which requires all
+*  eigenvalues and optionally eigenvectors of a dense or banded
+*  Hermitian matrix that has been reduced to tridiagonal form.
+*
+*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+*    where Z = Q'u, u is a vector of length N with ones in the
+*    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+*     The eigenvectors of the original matrix are stored in Q, and the
+*     eigenvalues are in D.  The algorithm consists of three stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple eigenvalues or if there is a zero in
+*        the Z vector.  For each such occurence the dimension of the
+*        secular equation problem is reduced by one.  This stage is
+*        performed by the routine SLAED2.
+*
+*        The second stage consists of calculating the updated
+*        eigenvalues. This is done by finding the roots of the secular
+*        equation via the routine SLAED4 (as called by SLAED3).
+*        This routine also calculates the eigenvectors of the current
+*        problem.
+*
+*        The final stage consists of computing the updated eigenvectors
+*        directly using the updated eigenvalues.  The eigenvectors for
+*        the current problem are multiplied with the eigenvectors from
+*        the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  CUTPNT (input) INTEGER
+*         Contains the location of the last eigenvalue in the leading
+*         sub-matrix.  min(1,N) <= CUTPNT <= N.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the unitary matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N.
+*
+*  TLVLS  (input) INTEGER
+*         The total number of merging levels in the overall divide and
+*         conquer tree.
+*
+*  CURLVL (input) INTEGER
+*         The current level in the overall merge routine,
+*         0 <= curlvl <= tlvls.
+*
+*  CURPBM (input) INTEGER
+*         The current problem in the current level in the overall
+*         merge routine (counting from upper left to lower right).
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, the eigenvalues of the rank-1-perturbed matrix.
+*         On exit, the eigenvalues of the repaired matrix.
+*
+*  Q      (input/output) COMPLEX array, dimension (LDQ,N)
+*         On entry, the eigenvectors of the rank-1-perturbed matrix.
+*         On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  RHO    (input) REAL
+*         Contains the subdiagonal element used to create the rank-1
+*         modification.
+*
+*  INDXQ  (output) INTEGER array, dimension (N)
+*         This contains the permutation which will reintegrate the
+*         subproblem just solved back into sorted order,
+*         ie. D( INDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  RWORK  (workspace) REAL array,
+*                                 dimension (3*N+2*QSIZ*N)
+*
+*  WORK   (workspace) COMPLEX array, dimension (QSIZ*N)
+*
+*  QSTORE (input/output) REAL array, dimension (N**2+1)
+*         Stores eigenvectors of submatrices encountered during
+*         divide and conquer, packed together. QPTR points to
+*         beginning of the submatrices.
+*
+*  QPTR   (input/output) INTEGER array, dimension (N+2)
+*         List of indices pointing to beginning of submatrices stored
+*         in QSTORE. The submatrices are numbered starting at the
+*         bottom left of the divide and conquer tree, from left to
+*         right and bottom to top.
+*
+*  PRMPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in PERM a
+*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
+*         indicates the size of the permutation and also the size of
+*         the full, non-deflated problem.
+*
+*  PERM   (input) INTEGER array, dimension (N lg N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in GIVCOL a
+*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
+*         indicates the number of Givens rotations.
+*
+*  GIVCOL (input) INTEGER array, dimension (2, N lg N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (input) REAL array, dimension (2, N lg N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            COLTYP, CURR, I, IDLMDA, INDX,
+     $                   INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+*     IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+*        INFO = -1
+*     ELSE IF( N.LT.0 ) THEN
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
+         INFO = -2
+      ELSE IF( QSIZ.LT.N ) THEN
+         INFO = -3
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLAED7', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in SLAED2 and SLAED3.
+*
+      IZ = 1
+      IDLMDA = IZ + N
+      IW = IDLMDA + N
+      IQ = IW + N
+*
+      INDX = 1
+      INDXC = INDX + N
+      COLTYP = INDXC + N
+      INDXP = COLTYP + N
+*
+*     Form the z-vector which consists of the last row of Q_1 and the
+*     first row of Q_2.
+*
+      PTR = 1 + 2**TLVLS
+      DO 10 I = 1, CURLVL - 1
+         PTR = PTR + 2**( TLVLS-I )
+   10 CONTINUE
+      CURR = PTR + CURPBM
+      CALL SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+     $             GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ),
+     $             RWORK( IZ+N ), INFO )
+*
+*     When solving the final problem, we no longer need the stored data,
+*     so we will overwrite the data from this level onto the previously
+*     used storage space.
+*
+      IF( CURLVL.EQ.TLVLS ) THEN
+         QPTR( CURR ) = 1
+         PRMPTR( CURR ) = 1
+         GIVPTR( CURR ) = 1
+      END IF
+*
+*     Sort and Deflate eigenvalues.
+*
+      CALL CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ),
+     $             RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ),
+     $             IWORK( INDXP ), IWORK( INDX ), INDXQ,
+     $             PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
+     $             GIVCOL( 1, GIVPTR( CURR ) ),
+     $             GIVNUM( 1, GIVPTR( CURR ) ), INFO )
+      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
+      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
+*
+*     Solve Secular Equation.
+*
+      IF( K.NE.0 ) THEN
+         CALL SLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
+     $                RWORK( IDLMDA ), RWORK( IW ),
+     $                QSTORE( QPTR( CURR ) ), K, INFO )
+         CALL CLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q,
+     $                LDQ, RWORK( IQ ) )
+         QPTR( CURR+1 ) = QPTR( CURR ) + K**2
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+*
+*     Prepare the INDXQ sorting premutation.
+*
+         N1 = K
+         N2 = N - K
+         CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
+      ELSE
+         QPTR( CURR+1 ) = QPTR( CURR )
+         DO 20 I = 1, N
+            INDXQ( I ) = I
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CLAED7
+*
+      END
diff --git a/SRC/claed8.f b/SRC/claed8.f
new file mode 100644
index 00000000..69047298
--- /dev/null
+++ b/SRC/claed8.f
@@ -0,0 +1,363 @@
+      SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
+     $                   Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
+     $                   GIVCOL, GIVNUM, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),
+     $                   INDXQ( * ), PERM( * )
+      REAL               D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
+     $                   Z( * )
+      COMPLEX            Q( LDQ, * ), Q2( LDQ2, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAED8 merges the two sets of eigenvalues together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  eigenvalues are close together or if there is a tiny element in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  Arguments
+*  =========
+*
+*  K      (output) INTEGER
+*         Contains the number of non-deflated eigenvalues.
+*         This is the order of the related secular equation.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the unitary matrix used to reduce
+*         the dense or band matrix to tridiagonal form.
+*         QSIZ >= N if ICOMPQ = 1.
+*
+*  Q      (input/output) COMPLEX array, dimension (LDQ,N)
+*         On entry, Q contains the eigenvectors of the partially solved
+*         system which has been previously updated in matrix
+*         multiplies with other partially solved eigensystems.
+*         On exit, Q contains the trailing (N-K) updated eigenvectors
+*         (those which were deflated) in its last N-K columns.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max( 1, N ).
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, D contains the eigenvalues of the two submatrices to
+*         be combined.  On exit, D contains the trailing (N-K) updated
+*         eigenvalues (those which were deflated) sorted into increasing
+*         order.
+*
+*  RHO    (input/output) REAL
+*         Contains the off diagonal element associated with the rank-1
+*         cut which originally split the two submatrices which are now
+*         being recombined. RHO is modified during the computation to
+*         the value required by SLAED3.
+*
+*  CUTPNT (input) INTEGER
+*         Contains the location of the last eigenvalue in the leading
+*         sub-matrix.  MIN(1,N) <= CUTPNT <= N.
+*
+*  Z      (input) REAL array, dimension (N)
+*         On input this vector contains the updating vector (the last
+*         row of the first sub-eigenvector matrix and the first row of
+*         the second sub-eigenvector matrix).  The contents of Z are
+*         destroyed during the updating process.
+*
+*  DLAMDA (output) REAL array, dimension (N)
+*         Contains a copy of the first K eigenvalues which will be used
+*         by SLAED3 to form the secular equation.
+*
+*  Q2     (output) COMPLEX array, dimension (LDQ2,N)
+*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
+*         Contains a copy of the first K eigenvectors which will be used
+*         by SLAED7 in a matrix multiply (SGEMM) to update the new
+*         eigenvectors.
+*
+*  LDQ2   (input) INTEGER
+*         The leading dimension of the array Q2.  LDQ2 >= max( 1, N ).
+*
+*  W      (output) REAL array, dimension (N)
+*         This will hold the first k values of the final
+*         deflation-altered z-vector and will be passed to SLAED3.
+*
+*  INDXP  (workspace) INTEGER array, dimension (N)
+*         This will contain the permutation used to place deflated
+*         values of D at the end of the array. On output INDXP(1:K)
+*         points to the nondeflated D-values and INDXP(K+1:N)
+*         points to the deflated eigenvalues.
+*
+*  INDX   (workspace) INTEGER array, dimension (N)
+*         This will contain the permutation used to sort the contents of
+*         D into ascending order.
+*
+*  INDXQ  (input) INTEGER array, dimension (N)
+*         This contains the permutation which separately sorts the two
+*         sub-problems in D into ascending order.  Note that elements in
+*         the second half of this permutation must first have CUTPNT
+*         added to their values in order to be accurate.
+*
+*  PERM   (output) INTEGER array, dimension (N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (output) INTEGER
+*         Contains the number of Givens rotations which took place in
+*         this subproblem.
+*
+*  GIVCOL (output) INTEGER array, dimension (2, N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (output) REAL array, dimension (2, N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               MONE, ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
+     $                   TWO = 2.0E0, EIGHT = 8.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
+      REAL               C, EPS, S, T, TAU, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           ISAMAX, SLAMCH, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CSROT, SCOPY, SLAMRG, SSCAL,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( QSIZ.LT.N ) THEN
+         INFO = -3
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
+         INFO = -8
+      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLAED8', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      N1 = CUTPNT
+      N2 = N - N1
+      N1P1 = N1 + 1
+*
+      IF( RHO.LT.ZERO ) THEN
+         CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
+      END IF
+*
+*     Normalize z so that norm(z) = 1
+*
+      T = ONE / SQRT( TWO )
+      DO 10 J = 1, N
+         INDX( J ) = J
+   10 CONTINUE
+      CALL SSCAL( N, T, Z, 1 )
+      RHO = ABS( TWO*RHO )
+*
+*     Sort the eigenvalues into increasing order
+*
+      DO 20 I = CUTPNT + 1, N
+         INDXQ( I ) = INDXQ( I ) + CUTPNT
+   20 CONTINUE
+      DO 30 I = 1, N
+         DLAMDA( I ) = D( INDXQ( I ) )
+         W( I ) = Z( INDXQ( I ) )
+   30 CONTINUE
+      I = 1
+      J = CUTPNT + 1
+      CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
+      DO 40 I = 1, N
+         D( I ) = DLAMDA( INDX( I ) )
+         Z( I ) = W( INDX( I ) )
+   40 CONTINUE
+*
+*     Calculate the allowable deflation tolerance
+*
+      IMAX = ISAMAX( N, Z, 1 )
+      JMAX = ISAMAX( N, D, 1 )
+      EPS = SLAMCH( 'Epsilon' )
+      TOL = EIGHT*EPS*ABS( D( JMAX ) )
+*
+*     If the rank-1 modifier is small enough, no more needs to be done
+*     -- except to reorganize Q so that its columns correspond with the
+*     elements in D.
+*
+      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+         K = 0
+         DO 50 J = 1, N
+            PERM( J ) = INDXQ( INDX( J ) )
+            CALL CCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+   50    CONTINUE
+         CALL CLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ )
+         RETURN
+      END IF
+*
+*     If there are multiple eigenvalues then the problem deflates.  Here
+*     the number of equal eigenvalues are found.  As each equal
+*     eigenvalue is found, an elementary reflector is computed to rotate
+*     the corresponding eigensubspace so that the corresponding
+*     components of Z are zero in this new basis.
+*
+      K = 0
+      GIVPTR = 0
+      K2 = N + 1
+      DO 60 J = 1, N
+         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            INDXP( K2 ) = J
+            IF( J.EQ.N )
+     $         GO TO 100
+         ELSE
+            JLAM = J
+            GO TO 70
+         END IF
+   60 CONTINUE
+   70 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 90
+      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         INDXP( K2 ) = J
+      ELSE
+*
+*        Check if eigenvalues are close enough to allow deflation.
+*
+         S = Z( JLAM )
+         C = Z( J )
+*
+*        Find sqrt(a**2+b**2) without overflow or
+*        destructive underflow.
+*
+         TAU = SLAPY2( C, S )
+         T = D( J ) - D( JLAM )
+         C = C / TAU
+         S = -S / TAU
+         IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            Z( J ) = TAU
+            Z( JLAM ) = ZERO
+*
+*           Record the appropriate Givens rotation
+*
+            GIVPTR = GIVPTR + 1
+            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
+            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
+            GIVNUM( 1, GIVPTR ) = C
+            GIVNUM( 2, GIVPTR ) = S
+            CALL CSROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
+     $                  Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
+            T = D( JLAM )*C*C + D( J )*S*S
+            D( J ) = D( JLAM )*S*S + D( J )*C*C
+            D( JLAM ) = T
+            K2 = K2 - 1
+            I = 1
+   80       CONTINUE
+            IF( K2+I.LE.N ) THEN
+               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
+                  INDXP( K2+I-1 ) = INDXP( K2+I )
+                  INDXP( K2+I ) = JLAM
+                  I = I + 1
+                  GO TO 80
+               ELSE
+                  INDXP( K2+I-1 ) = JLAM
+               END IF
+            ELSE
+               INDXP( K2+I-1 ) = JLAM
+            END IF
+            JLAM = J
+         ELSE
+            K = K + 1
+            W( K ) = Z( JLAM )
+            DLAMDA( K ) = D( JLAM )
+            INDXP( K ) = JLAM
+            JLAM = J
+         END IF
+      END IF
+      GO TO 70
+   90 CONTINUE
+*
+*     Record the last eigenvalue.
+*
+      K = K + 1
+      W( K ) = Z( JLAM )
+      DLAMDA( K ) = D( JLAM )
+      INDXP( K ) = JLAM
+*
+  100 CONTINUE
+*
+*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+*     and Q2 respectively.  The eigenvalues/vectors which were not
+*     deflated go into the first K slots of DLAMDA and Q2 respectively,
+*     while those which were deflated go into the last N - K slots.
+*
+      DO 110 J = 1, N
+         JP = INDXP( J )
+         DLAMDA( J ) = D( JP )
+         PERM( J ) = INDXQ( INDX( JP ) )
+         CALL CCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+  110 CONTINUE
+*
+*     The deflated eigenvalues and their corresponding vectors go back
+*     into the last N - K slots of D and Q respectively.
+*
+      IF( K.LT.N ) THEN
+         CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+         CALL CLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ),
+     $                LDQ )
+      END IF
+*
+      RETURN
+*
+*     End of CLAED8
+*
+      END
diff --git a/SRC/claein.f b/SRC/claein.f
new file mode 100644
index 00000000..97b19b02
--- /dev/null
+++ b/SRC/claein.f
@@ -0,0 +1,263 @@
+      SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK,
+     $                   EPS3, SMLNUM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            NOINIT, RIGHTV
+      INTEGER            INFO, LDB, LDH, N
+      REAL               EPS3, SMLNUM
+      COMPLEX            W
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            B( LDB, * ), H( LDH, * ), V( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAEIN uses inverse iteration to find a right or left eigenvector
+*  corresponding to the eigenvalue W of a complex upper Hessenberg
+*  matrix H.
+*
+*  Arguments
+*  =========
+*
+*  RIGHTV   (input) LOGICAL
+*          = .TRUE. : compute right eigenvector;
+*          = .FALSE.: compute left eigenvector.
+*
+*  NOINIT   (input) LOGICAL
+*          = .TRUE. : no initial vector supplied in V
+*          = .FALSE.: initial vector supplied in V.
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) COMPLEX array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  W       (input) COMPLEX
+*          The eigenvalue of H whose corresponding right or left
+*          eigenvector is to be computed.
+*
+*  V       (input/output) COMPLEX array, dimension (N)
+*          On entry, if NOINIT = .FALSE., V must contain a starting
+*          vector for inverse iteration; otherwise V need not be set.
+*          On exit, V contains the computed eigenvector, normalized so
+*          that the component of largest magnitude has magnitude 1; here
+*          the magnitude of a complex number (x,y) is taken to be
+*          |x| + |y|.
+*
+*  B       (workspace) COMPLEX array, dimension (LDB,N)
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  EPS3    (input) REAL
+*          A small machine-dependent value which is used to perturb
+*          close eigenvalues, and to replace zero pivots.
+*
+*  SMLNUM  (input) REAL
+*          A machine-dependent value close to the underflow threshold.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          = 1:  inverse iteration did not converge; V is set to the
+*                last iterate.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, TENTH
+      PARAMETER          ( ONE = 1.0E+0, TENTH = 1.0E-1 )
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          NORMIN, TRANS
+      INTEGER            I, IERR, ITS, J
+      REAL               GROWTO, NRMSML, ROOTN, RTEMP, SCALE, VNORM
+      COMPLEX            CDUM, EI, EJ, TEMP, X
+*     ..
+*     .. External Functions ..
+      INTEGER            ICAMAX
+      REAL               SCASUM, SCNRM2
+      COMPLEX            CLADIV
+      EXTERNAL           ICAMAX, SCASUM, SCNRM2, CLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLATRS, CSSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     GROWTO is the threshold used in the acceptance test for an
+*     eigenvector.
+*
+      ROOTN = SQRT( REAL( N ) )
+      GROWTO = TENTH / ROOTN
+      NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
+*
+*     Form B = H - W*I (except that the subdiagonal elements are not
+*     stored).
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, J - 1
+            B( I, J ) = H( I, J )
+   10    CONTINUE
+         B( J, J ) = H( J, J ) - W
+   20 CONTINUE
+*
+      IF( NOINIT ) THEN
+*
+*        Initialize V.
+*
+         DO 30 I = 1, N
+            V( I ) = EPS3
+   30    CONTINUE
+      ELSE
+*
+*        Scale supplied initial vector.
+*
+         VNORM = SCNRM2( N, V, 1 )
+         CALL CSSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), V, 1 )
+      END IF
+*
+      IF( RIGHTV ) THEN
+*
+*        LU decomposition with partial pivoting of B, replacing zero
+*        pivots by EPS3.
+*
+         DO 60 I = 1, N - 1
+            EI = H( I+1, I )
+            IF( CABS1( B( I, I ) ).LT.CABS1( EI ) ) THEN
+*
+*              Interchange rows and eliminate.
+*
+               X = CLADIV( B( I, I ), EI )
+               B( I, I ) = EI
+               DO 40 J = I + 1, N
+                  TEMP = B( I+1, J )
+                  B( I+1, J ) = B( I, J ) - X*TEMP
+                  B( I, J ) = TEMP
+   40          CONTINUE
+            ELSE
+*
+*              Eliminate without interchange.
+*
+               IF( B( I, I ).EQ.ZERO )
+     $            B( I, I ) = EPS3
+               X = CLADIV( EI, B( I, I ) )
+               IF( X.NE.ZERO ) THEN
+                  DO 50 J = I + 1, N
+                     B( I+1, J ) = B( I+1, J ) - X*B( I, J )
+   50             CONTINUE
+               END IF
+            END IF
+   60    CONTINUE
+         IF( B( N, N ).EQ.ZERO )
+     $      B( N, N ) = EPS3
+*
+         TRANS = 'N'
+*
+      ELSE
+*
+*        UL decomposition with partial pivoting of B, replacing zero
+*        pivots by EPS3.
+*
+         DO 90 J = N, 2, -1
+            EJ = H( J, J-1 )
+            IF( CABS1( B( J, J ) ).LT.CABS1( EJ ) ) THEN
+*
+*              Interchange columns and eliminate.
+*
+               X = CLADIV( B( J, J ), EJ )
+               B( J, J ) = EJ
+               DO 70 I = 1, J - 1
+                  TEMP = B( I, J-1 )
+                  B( I, J-1 ) = B( I, J ) - X*TEMP
+                  B( I, J ) = TEMP
+   70          CONTINUE
+            ELSE
+*
+*              Eliminate without interchange.
+*
+               IF( B( J, J ).EQ.ZERO )
+     $            B( J, J ) = EPS3
+               X = CLADIV( EJ, B( J, J ) )
+               IF( X.NE.ZERO ) THEN
+                  DO 80 I = 1, J - 1
+                     B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
+   80             CONTINUE
+               END IF
+            END IF
+   90    CONTINUE
+         IF( B( 1, 1 ).EQ.ZERO )
+     $      B( 1, 1 ) = EPS3
+*
+         TRANS = 'C'
+*
+      END IF
+*
+      NORMIN = 'N'
+      DO 110 ITS = 1, N
+*
+*        Solve U*x = scale*v for a right eigenvector
+*          or U'*x = scale*v for a left eigenvector,
+*        overwriting x on v.
+*
+         CALL CLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB, V,
+     $                SCALE, RWORK, IERR )
+         NORMIN = 'Y'
+*
+*        Test for sufficient growth in the norm of v.
+*
+         VNORM = SCASUM( N, V, 1 )
+         IF( VNORM.GE.GROWTO*SCALE )
+     $      GO TO 120
+*
+*        Choose new orthogonal starting vector and try again.
+*
+         RTEMP = EPS3 / ( ROOTN+ONE )
+         V( 1 ) = EPS3
+         DO 100 I = 2, N
+            V( I ) = RTEMP
+  100    CONTINUE
+         V( N-ITS+1 ) = V( N-ITS+1 ) - EPS3*ROOTN
+  110 CONTINUE
+*
+*     Failure to find eigenvector in N iterations.
+*
+      INFO = 1
+*
+  120 CONTINUE
+*
+*     Normalize eigenvector.
+*
+      I = ICAMAX( N, V, 1 )
+      CALL CSSCAL( N, ONE / CABS1( V( I ) ), V, 1 )
+*
+      RETURN
+*
+*     End of CLAEIN
+*
+      END
diff --git a/SRC/claesy.f b/SRC/claesy.f
new file mode 100644
index 00000000..257752f5
--- /dev/null
+++ b/SRC/claesy.f
@@ -0,0 +1,152 @@
+      SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      COMPLEX            A, B, C, CS1, EVSCAL, RT1, RT2, SN1
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix
+*     ( ( A, B );( B, C ) )
+*  provided the norm of the matrix of eigenvectors is larger than
+*  some threshold value.
+*
+*  RT1 is the eigenvalue of larger absolute value, and RT2 of
+*  smaller absolute value.  If the eigenvectors are computed, then
+*  on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence
+*
+*  [  CS1     SN1   ] . [ A  B ] . [ CS1    -SN1   ] = [ RT1  0  ]
+*  [ -SN1     CS1   ]   [ B  C ]   [ SN1     CS1   ]   [  0  RT2 ]
+*
+*  Arguments
+*  =========
+*
+*  A       (input) COMPLEX
+*          The ( 1, 1 ) element of input matrix.
+*
+*  B       (input) COMPLEX
+*          The ( 1, 2 ) element of input matrix.  The ( 2, 1 ) element
+*          is also given by B, since the 2-by-2 matrix is symmetric.
+*
+*  C       (input) COMPLEX
+*          The ( 2, 2 ) element of input matrix.
+*
+*  RT1     (output) COMPLEX
+*          The eigenvalue of larger modulus.
+*
+*  RT2     (output) COMPLEX
+*          The eigenvalue of smaller modulus.
+*
+*  EVSCAL  (output) COMPLEX
+*          The complex value by which the eigenvector matrix was scaled
+*          to make it orthonormal.  If EVSCAL is zero, the eigenvectors
+*          were not computed.  This means one of two things:  the 2-by-2
+*          matrix could not be diagonalized, or the norm of the matrix
+*          of eigenvectors before scaling was larger than the threshold
+*          value THRESH (set below).
+*
+*  CS1     (output) COMPLEX
+*  SN1     (output) COMPLEX
+*          If EVSCAL .NE. 0,  ( CS1, SN1 ) is the unit right eigenvector
+*          for RT1.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E0, 0.0E0 ) )
+      REAL               HALF
+      PARAMETER          ( HALF = 0.5E0 )
+      REAL               THRESH
+      PARAMETER          ( THRESH = 0.1E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               BABS, EVNORM, TABS, Z
+      COMPLEX            S, T, TMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*
+*     Special case:  The matrix is actually diagonal.
+*     To avoid divide by zero later, we treat this case separately.
+*
+      IF( ABS( B ).EQ.ZERO ) THEN
+         RT1 = A
+         RT2 = C
+         IF( ABS( RT1 ).LT.ABS( RT2 ) ) THEN
+            TMP = RT1
+            RT1 = RT2
+            RT2 = TMP
+            CS1 = ZERO
+            SN1 = ONE
+         ELSE
+            CS1 = ONE
+            SN1 = ZERO
+         END IF
+      ELSE
+*
+*        Compute the eigenvalues and eigenvectors.
+*        The characteristic equation is
+*           lambda **2 - (A+C) lambda + (A*C - B*B)
+*        and we solve it using the quadratic formula.
+*
+         S = ( A+C )*HALF
+         T = ( A-C )*HALF
+*
+*        Take the square root carefully to avoid over/under flow.
+*
+         BABS = ABS( B )
+         TABS = ABS( T )
+         Z = MAX( BABS, TABS )
+         IF( Z.GT.ZERO )
+     $      T = Z*SQRT( ( T / Z )**2+( B / Z )**2 )
+*
+*        Compute the two eigenvalues.  RT1 and RT2 are exchanged
+*        if necessary so that RT1 will have the greater magnitude.
+*
+         RT1 = S + T
+         RT2 = S - T
+         IF( ABS( RT1 ).LT.ABS( RT2 ) ) THEN
+            TMP = RT1
+            RT1 = RT2
+            RT2 = TMP
+         END IF
+*
+*        Choose CS1 = 1 and SN1 to satisfy the first equation, then
+*        scale the components of this eigenvector so that the matrix
+*        of eigenvectors X satisfies  X * X' = I .  (No scaling is
+*        done if the norm of the eigenvalue matrix is less than THRESH.)
+*
+         SN1 = ( RT1-A ) / B
+         TABS = ABS( SN1 )
+         IF( TABS.GT.ONE ) THEN
+            T = TABS*SQRT( ( ONE / TABS )**2+( SN1 / TABS )**2 )
+         ELSE
+            T = SQRT( CONE+SN1*SN1 )
+         END IF
+         EVNORM = ABS( T )
+         IF( EVNORM.GE.THRESH ) THEN
+            EVSCAL = CONE / T
+            CS1 = EVSCAL
+            SN1 = SN1*EVSCAL
+         ELSE
+            EVSCAL = ZERO
+         END IF
+      END IF
+      RETURN
+*
+*     End of CLAESY
+*
+      END
diff --git a/SRC/claev2.f b/SRC/claev2.f
new file mode 100644
index 00000000..aca90fcb
--- /dev/null
+++ b/SRC/claev2.f
@@ -0,0 +1,95 @@
+      SUBROUTINE CLAEV2( 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 ..
+      REAL               CS1, RT1, RT2
+      COMPLEX            A, B, C, SN1
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
+*     [  A         B  ]
+*     [  CONJG(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  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]
+*  [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].
+*
+*  Arguments
+*  =========
+*
+*  A      (input) COMPLEX
+*         The (1,1) element of the 2-by-2 matrix.
+*
+*  B      (input) COMPLEX
+*         The (1,2) element and the conjugate of the (2,1) element of
+*         the 2-by-2 matrix.
+*
+*  C      (input) COMPLEX
+*         The (2,2) element of the 2-by-2 matrix.
+*
+*  RT1    (output) REAL
+*         The eigenvalue of larger absolute value.
+*
+*  RT2    (output) REAL
+*         The eigenvalue of smaller absolute value.
+*
+*  CS1    (output) REAL
+*  SN1    (output) COMPLEX
+*         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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               T
+      COMPLEX            W
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAEV2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ABS( B ).EQ.ZERO ) THEN
+         W = ONE
+      ELSE
+         W = CONJG( B ) / ABS( B )
+      END IF
+      CALL SLAEV2( REAL( A ), ABS( B ), REAL( C ), RT1, RT2, CS1, T )
+      SN1 = W*T
+      RETURN
+*
+*     End of CLAEV2
+*
+      END
diff --git a/SRC/clag2z.f b/SRC/clag2z.f
new file mode 100644
index 00000000..a2fdbda3
--- /dev/null
+++ b/SRC/clag2z.f
@@ -0,0 +1,74 @@
+      SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO)
+*
+*  -- LAPACK PROTOTYPE auxilary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     ..
+*     .. WARNING: PROTOTYPE ..
+*     This is an LAPACK PROTOTYPE routine which means that the
+*     interface of this routine is likely to be changed in the future
+*     based on community feedback.
+*
+*     ..
+*     .. Scalar Arguments ..
+      INTEGER INFO,LDA,LDSA,M,N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX SA(LDSA,*)
+      COMPLEX*16 A(LDA,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAG2Z converts a COMPLEX SINGLE PRECISION matrix, SA, to a COMPLEX
+*  DOUBLE PRECISION matrix, A.
+*
+*  Note that while it is possible to overflow while converting 
+*  from double to single, it is not possible to overflow when
+*  converting from single to double. 
+*
+*  This is a helper routine so there is no argument checking.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of lines of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  SA      (output) REAL array, dimension (LDSA,N)
+*          On exit, the M-by-N coefficient matrix SA.
+*
+*  LDSA    (input) INTEGER
+*          The leading dimension of the array SA.  LDSA >= max(1,M).
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N coefficient matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*  =========
+*
+*     .. Local Scalars ..
+      INTEGER I,J
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      DO 20 J = 1,N
+          DO 30 I = 1,M
+              A(I,J) = SA(I,J)
+   30     CONTINUE
+   20 CONTINUE
+      RETURN
+*
+*     End of CLAG2Z
+*
+      END
diff --git a/SRC/clags2.f b/SRC/clags2.f
new file mode 100644
index 00000000..d926d61b
--- /dev/null
+++ b/SRC/clags2.f
@@ -0,0 +1,304 @@
+      SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
+     $                   SNV, CSQ, SNQ )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            UPPER
+      REAL               A1, A3, B1, B3, CSQ, CSU, CSV
+      COMPLEX            A2, B2, SNQ, SNU, SNV
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such
+*  that if ( UPPER ) then
+*
+*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
+*                        ( 0  A3 )     ( x  x  )
+*  and
+*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
+*                        ( 0  B3 )     ( x  x  )
+*
+*  or if ( .NOT.UPPER ) then
+*
+*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
+*                        ( A2 A3 )     ( 0  x  )
+*  and
+*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
+*                        ( B2 B3 )     ( 0  x  )
+*  where
+*
+*    U = (     CSU      SNU ), V = (     CSV     SNV ),
+*        ( -CONJG(SNU)  CSU )      ( -CONJG(SNV) CSV )
+*
+*    Q = (     CSQ      SNQ )
+*        ( -CONJG(SNQ)  CSQ )
+*
+*  Z' denotes the conjugate transpose of Z.
+*
+*  The rows of the transformed A and B are parallel. Moreover, if the
+*  input 2-by-2 matrix A is not zero, then the transformed (1,1) entry
+*  of A is not zero. If the input matrices A and B are both not zero,
+*  then the transformed (2,2) element of B is not zero, except when the
+*  first rows of input A and B are parallel and the second rows are
+*  zero.
+*
+*  Arguments
+*  =========
+*
+*  UPPER   (input) LOGICAL
+*          = .TRUE.: the input matrices A and B are upper triangular.
+*          = .FALSE.: the input matrices A and B are lower triangular.
+*
+*  A1      (input) REAL
+*  A2      (input) COMPLEX
+*  A3      (input) REAL
+*          On entry, A1, A2 and A3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix A.
+*
+*  B1      (input) REAL
+*  B2      (input) COMPLEX
+*  B3      (input) REAL
+*          On entry, B1, B2 and B3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix B.
+*
+*  CSU     (output) REAL
+*  SNU     (output) COMPLEX
+*          The desired unitary matrix U.
+*
+*  CSV     (output) REAL
+*  SNV     (output) COMPLEX
+*          The desired unitary matrix V.
+*
+*  CSQ     (output) REAL
+*  SNQ     (output) COMPLEX
+*          The desired unitary matrix Q.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
+     $                   AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2, SNL,
+     $                   SNR, UA11R, UA22R, VB11R, VB22R
+      COMPLEX            B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
+     $                   VB12, VB21, VB22
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARTG, SLASV2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( T ) = ABS( REAL( T ) ) + ABS( AIMAG( T ) )
+*     ..
+*     .. Executable Statements ..
+*
+      IF( UPPER ) THEN
+*
+*        Input matrices A and B are upper triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a b )
+*                                   ( 0 d )
+*
+         A = A1*B3
+         D = A3*B1
+         B = A2*B1 - A1*B2
+         FB = ABS( B )
+*
+*        Transform complex 2-by-2 matrix C to real matrix by unitary
+*        diagonal matrix diag(1,D1).
+*
+         D1 = ONE
+         IF( FB.NE.ZERO )
+     $      D1 = B / FB
+*
+*        The SVD of real 2 by 2 triangular C
+*
+*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL SLASV2( A, FB, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
+     $        THEN
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11R = CSL*A1
+            UA12 = CSL*A2 + D1*SNL*A3
+*
+            VB11R = CSR*B1
+            VB12 = CSR*B2 + D1*SNR*B3
+*
+            AUA12 = ABS( CSL )*ABS1( A2 ) + ABS( SNL )*ABS( A3 )
+            AVB12 = ABS( CSR )*ABS1( B2 ) + ABS( SNR )*ABS( B3 )
+*
+*           zero (1,2) elements of U'*A and V'*B
+*
+            IF( ( ABS( UA11R )+ABS1( UA12 ) ).EQ.ZERO ) THEN
+               CALL CLARTG( -CMPLX( VB11R ), CONJG( VB12 ), CSQ, SNQ,
+     $                      R )
+            ELSE IF( ( ABS( VB11R )+ABS1( VB12 ) ).EQ.ZERO ) THEN
+               CALL CLARTG( -CMPLX( UA11R ), CONJG( UA12 ), CSQ, SNQ,
+     $                      R )
+            ELSE IF( AUA12 / ( ABS( UA11R )+ABS1( UA12 ) ).LE.AVB12 /
+     $               ( ABS( VB11R )+ABS1( VB12 ) ) ) THEN
+               CALL CLARTG( -CMPLX( UA11R ), CONJG( UA12 ), CSQ, SNQ,
+     $                      R )
+            ELSE
+               CALL CLARTG( -CMPLX( VB11R ), CONJG( VB12 ), CSQ, SNQ,
+     $                      R )
+            END IF
+*
+            CSU = CSL
+            SNU = -D1*SNL
+            CSV = CSR
+            SNV = -D1*SNR
+*
+         ELSE
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -CONJG( D1 )*SNL*A1
+            UA22 = -CONJG( D1 )*SNL*A2 + CSL*A3
+*
+            VB21 = -CONJG( D1 )*SNR*B1
+            VB22 = -CONJG( D1 )*SNR*B2 + CSR*B3
+*
+            AUA22 = ABS( SNL )*ABS1( A2 ) + ABS( CSL )*ABS( A3 )
+            AVB22 = ABS( SNR )*ABS1( B2 ) + ABS( CSR )*ABS( B3 )
+*
+*           zero (2,2) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS1( UA21 )+ABS1( UA22 ) ).EQ.ZERO ) THEN
+               CALL CLARTG( -CONJG( VB21 ), CONJG( VB22 ), CSQ, SNQ, R )
+            ELSE IF( ( ABS1( VB21 )+ABS( VB22 ) ).EQ.ZERO ) THEN
+               CALL CLARTG( -CONJG( UA21 ), CONJG( UA22 ), CSQ, SNQ, R )
+            ELSE IF( AUA22 / ( ABS1( UA21 )+ABS1( UA22 ) ).LE.AVB22 /
+     $               ( ABS1( VB21 )+ABS1( VB22 ) ) ) THEN
+               CALL CLARTG( -CONJG( UA21 ), CONJG( UA22 ), CSQ, SNQ, R )
+            ELSE
+               CALL CLARTG( -CONJG( VB21 ), CONJG( VB22 ), CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNL
+            SNU = D1*CSL
+            CSV = SNR
+            SNV = D1*CSR
+*
+         END IF
+*
+      ELSE
+*
+*        Input matrices A and B are lower triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a 0 )
+*                                   ( c d )
+*
+         A = A1*B3
+         D = A3*B1
+         C = A2*B3 - A3*B2
+         FC = ABS( C )
+*
+*        Transform complex 2-by-2 matrix C to real matrix by unitary
+*        diagonal matrix diag(d1,1).
+*
+         D1 = ONE
+         IF( FC.NE.ZERO )
+     $      D1 = C / FC
+*
+*        The SVD of real 2 by 2 triangular C
+*
+*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL SLASV2( A, FC, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
+     $        THEN
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -D1*SNR*A1 + CSR*A2
+            UA22R = CSR*A3
+*
+            VB21 = -D1*SNL*B1 + CSL*B2
+            VB22R = CSL*B3
+*
+            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS1( A2 )
+            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS1( B2 )
+*
+*           zero (2,1) elements of U'*A and V'*B.
+*
+            IF( ( ABS1( UA21 )+ABS( UA22R ) ).EQ.ZERO ) THEN
+               CALL CLARTG( CMPLX( VB22R ), VB21, CSQ, SNQ, R )
+            ELSE IF( ( ABS1( VB21 )+ABS( VB22R ) ).EQ.ZERO ) THEN
+               CALL CLARTG( CMPLX( UA22R ), UA21, CSQ, SNQ, R )
+            ELSE IF( AUA21 / ( ABS1( UA21 )+ABS( UA22R ) ).LE.AVB21 /
+     $               ( ABS1( VB21 )+ABS( VB22R ) ) ) THEN
+               CALL CLARTG( CMPLX( UA22R ), UA21, CSQ, SNQ, R )
+            ELSE
+               CALL CLARTG( CMPLX( VB22R ), VB21, CSQ, SNQ, R )
+            END IF
+*
+            CSU = CSR
+            SNU = -CONJG( D1 )*SNR
+            CSV = CSL
+            SNV = -CONJG( D1 )*SNL
+*
+         ELSE
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11 = CSR*A1 + CONJG( D1 )*SNR*A2
+            UA12 = CONJG( D1 )*SNR*A3
+*
+            VB11 = CSL*B1 + CONJG( D1 )*SNL*B2
+            VB12 = CONJG( D1 )*SNL*B3
+*
+            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS1( A2 )
+            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS1( B2 )
+*
+*           zero (1,1) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS1( UA11 )+ABS1( UA12 ) ).EQ.ZERO ) THEN
+               CALL CLARTG( VB12, VB11, CSQ, SNQ, R )
+            ELSE IF( ( ABS1( VB11 )+ABS1( VB12 ) ).EQ.ZERO ) THEN
+               CALL CLARTG( UA12, UA11, CSQ, SNQ, R )
+            ELSE IF( AUA11 / ( ABS1( UA11 )+ABS1( UA12 ) ).LE.AVB11 /
+     $               ( ABS1( VB11 )+ABS1( VB12 ) ) ) THEN
+               CALL CLARTG( UA12, UA11, CSQ, SNQ, R )
+            ELSE
+               CALL CLARTG( VB12, VB11, CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNR
+            SNU = CONJG( D1 )*CSR
+            CSV = SNL
+            SNV = CONJG( D1 )*CSL
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of CLAGS2
+*
+      END
diff --git a/SRC/clagtm.f b/SRC/clagtm.f
new file mode 100644
index 00000000..8723b258
--- /dev/null
+++ b/SRC/clagtm.f
@@ -0,0 +1,233 @@
+      SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
+     $                   B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            LDB, LDX, N, NRHS
+      REAL               ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            B( LDB, * ), D( * ), DL( * ), DU( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAGTM performs a matrix-vector product of the form
+*
+*     B := alpha * A * X + beta * B
+*
+*  where A is a tridiagonal matrix of order N, B and X are N by NRHS
+*  matrices, and alpha and beta are real scalars, each of which may be
+*  0., 1., or -1.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the operation applied to A.
+*          = 'N':  No transpose, B := alpha * A * X + beta * B
+*          = 'T':  Transpose,    B := alpha * A**T * X + beta * B
+*          = 'C':  Conjugate transpose, B := alpha * A**H * X + beta * B
+*
+*  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 X and B.
+*
+*  ALPHA   (input) REAL
+*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 0.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of T.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The diagonal elements of T.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) super-diagonal elements of T.
+*
+*  X       (input) COMPLEX array, dimension (LDX,NRHS)
+*          The N by NRHS matrix X.
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(N,1).
+*
+*  BETA    (input) REAL
+*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 1.
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the N by NRHS matrix B.
+*          On exit, B is overwritten by the matrix expression
+*          B := alpha * A * X + beta * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(N,1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Multiply B by BETA if BETA.NE.1.
+*
+      IF( BETA.EQ.ZERO ) THEN
+         DO 20 J = 1, NRHS
+            DO 10 I = 1, N
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( BETA.EQ.-ONE ) THEN
+         DO 40 J = 1, NRHS
+            DO 30 I = 1, N
+               B( I, J ) = -B( I, J )
+   30       CONTINUE
+   40    CONTINUE
+      END IF
+*
+      IF( ALPHA.EQ.ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B + A*X
+*
+            DO 60 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 50 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DU( I )*X( I+1, J )
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Compute B := B + A**T * X
+*
+            DO 80 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 70 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DL( I )*X( I+1, J )
+   70             CONTINUE
+               END IF
+   80       CONTINUE
+         ELSE IF( LSAME( TRANS, 'C' ) ) THEN
+*
+*           Compute B := B + A**H * X
+*
+            DO 100 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + CONJG( D( 1 ) )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + CONJG( D( 1 ) )*X( 1, J ) +
+     $                        CONJG( DL( 1 ) )*X( 2, J )
+                  B( N, J ) = B( N, J ) + CONJG( DU( N-1 ) )*
+     $                        X( N-1, J ) + CONJG( D( N ) )*X( N, J )
+                  DO 90 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + CONJG( DU( I-1 ) )*
+     $                           X( I-1, J ) + CONJG( D( I ) )*
+     $                           X( I, J ) + CONJG( DL( I ) )*
+     $                           X( I+1, J )
+   90             CONTINUE
+               END IF
+  100       CONTINUE
+         END IF
+      ELSE IF( ALPHA.EQ.-ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B - A*X
+*
+            DO 120 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 110 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DU( I )*X( I+1, J )
+  110             CONTINUE
+               END IF
+  120       CONTINUE
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Compute B := B - A'*X
+*
+            DO 140 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 130 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DL( I )*X( I+1, J )
+  130             CONTINUE
+               END IF
+  140       CONTINUE
+         ELSE IF( LSAME( TRANS, 'C' ) ) THEN
+*
+*           Compute B := B - A'*X
+*
+            DO 160 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - CONJG( D( 1 ) )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - CONJG( D( 1 ) )*X( 1, J ) -
+     $                        CONJG( DL( 1 ) )*X( 2, J )
+                  B( N, J ) = B( N, J ) - CONJG( DU( N-1 ) )*
+     $                        X( N-1, J ) - CONJG( D( N ) )*X( N, J )
+                  DO 150 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - CONJG( DU( I-1 ) )*
+     $                           X( I-1, J ) - CONJG( D( I ) )*
+     $                           X( I, J ) - CONJG( DL( I ) )*
+     $                           X( I+1, J )
+  150             CONTINUE
+               END IF
+  160       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of CLAGTM
+*
+      END
diff --git a/SRC/clahef.f b/SRC/clahef.f
new file mode 100644
index 00000000..6c069d70
--- /dev/null
+++ b/SRC/clahef.f
@@ -0,0 +1,647 @@
+      SUBROUTINE CLAHEF( 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( * )
+      COMPLEX            A( LDA, * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAHEF computes a partial factorization of a complex Hermitian
+*  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.
+*  Note that U' denotes the conjugate transpose of U.
+*
+*  CLAHEF is an auxiliary routine called by CHETRF. 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
+*          Hermitian 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) COMPLEX 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, 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) COMPLEX 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+     $                   KSTEP, KW
+      REAL               ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T
+      COMPLEX            D11, D21, D22, Z
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      EXTERNAL           LSAME, ICAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMM, CGEMV, CLACGV, CSSCAL, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+*     ..
+*     .. 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 (note that conjg(W) is actually stored)
+*
+*        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 CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
+         W( K, KW ) = REAL( A( K, K ) )
+         IF( K.LT.N ) THEN
+            CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+     $                  W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+            W( K, KW ) = REAL( W( K, KW ) )
+         END IF
+*
+         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( REAL( 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 = ICAMAX( K-1, W( 1, KW ), 1 )
+            COLMAX = CABS1( 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
+            A( K, K ) = REAL( A( K, 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 CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+               W( IMAX, KW-1 ) = REAL( A( IMAX, IMAX ) )
+               CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+     $                     W( IMAX+1, KW-1 ), 1 )
+               CALL CLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               IF( K.LT.N ) THEN
+                  CALL CGEMV( 'No transpose', K, N-K, -CONE,
+     $                        A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+     $                        CONE, W( 1, KW-1 ), 1 )
+                  W( IMAX, KW-1 ) = REAL( W( IMAX, KW-1 ) )
+               END IF
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, KW-1 ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( REAL( 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 CCOPY( 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, KP ) = REAL( A( KK, KK ) )
+               CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
+               CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+*              Interchange rows KK and KP in last KK columns of A and W
+*
+               IF( KK.LT.N )
+     $            CALL CSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ),
+     $                        LDA )
+               CALL CSWAP( 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 CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+               R1 = ONE / REAL( A( K, K ) )
+               CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
+*
+*              Conjugate W(k)
+*
+               CALL CLACGV( K-1, W( 1, KW ), 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 ) / CONJG( D21 )
+                  D22 = W( K-1, KW-1 ) / D21
+                  T = ONE / ( REAL( 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 ) = CONJG( 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 )
+*
+*              Conjugate W(k) and W(k-1)
+*
+               CALL CLACGV( K-1, W( 1, KW ), 1 )
+               CALL CLACGV( K-2, W( 1, KW-1 ), 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
+*
+*        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 (note that conjg(W) is
+*        actually stored)
+*
+         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
+               A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+               CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+     $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+     $                     A( J, JJ ), 1 )
+               A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+   40       CONTINUE
+*
+*           Update the rectangular superdiagonal block
+*
+            CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+     $                  -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+     $                  CONE, 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 CSWAP( 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 (note that conjg(W) is actually stored)
+*
+*        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
+*
+         W( K, K ) = REAL( A( K, K ) )
+         IF( K.LT.N )
+     $      CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
+         CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
+     $               W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+         W( K, K ) = REAL( W( K, K ) )
+*
+         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( REAL( 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 + ICAMAX( N-K, W( K+1, K ), 1 )
+            COLMAX = CABS1( 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
+            A( K, K ) = REAL( A( K, 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 CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+               CALL CLACGV( IMAX-K, W( K, K+1 ), 1 )
+               W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) )
+               IF( IMAX.LT.N )
+     $            CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
+     $                        W( IMAX+1, K+1 ), 1 )
+               CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+     $                     LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ),
+     $                     1 )
+               W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) )
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, K+1 ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( REAL( 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 CCOPY( 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, KP ) = REAL( A( KK, KK ) )
+               CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+     $                     LDA )
+               CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
+               IF( KP.LT.N )
+     $            CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+*
+*              Interchange rows KK and KP in first KK columns of A and W
+*
+               CALL CSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+               CALL CSWAP( 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 CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+               IF( K.LT.N ) THEN
+                  R1 = ONE / REAL( A( K, K ) )
+                  CALL CSSCAL( N-K, R1, A( K+1, K ), 1 )
+*
+*                 Conjugate W(k)
+*
+                  CALL CLACGV( N-K, W( 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 ) / CONJG( D21 )
+                  T = ONE / ( REAL( D11*D22 )-ONE )
+                  D21 = T / D21
+                  DO 80 J = K + 2, N
+                     A( J, K ) = CONJG( 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 )
+*
+*              Conjugate W(k) and W(k+1)
+*
+               CALL CLACGV( N-K, W( K+1, K ), 1 )
+               CALL CLACGV( N-K-1, W( K+2, K+1 ), 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 (note that conjg(W) is
+*        actually stored)
+*
+         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
+               A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+               CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+     $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+     $                     A( JJ, JJ ), 1 )
+               A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+  100       CONTINUE
+*
+*           Update the rectangular subdiagonal block
+*
+            IF( J+JB.LE.N )
+     $         CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+     $                     K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+     $                     LDW, CONE, 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 CSWAP( 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 CLAHEF
+*
+      END
diff --git a/SRC/clahqr.f b/SRC/clahqr.f
new file mode 100644
index 00000000..5541ec8a
--- /dev/null
+++ b/SRC/clahqr.f
@@ -0,0 +1,469 @@
+      SUBROUTINE CLAHQR( 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            H( LDH, * ), W( * ), Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     CLAHQR 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).
+*          CLAHQR 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 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 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 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, CLAHQR 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 CLAHQR 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               RZERO, RONE, HALF
+      PARAMETER          ( RZERO = 0.0e0, RONE = 1.0e0, HALF = 0.5e0 )
+      REAL               DAT1
+      PARAMETER          ( DAT1 = 3.0e0 / 4.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
+     $                   V2, X, Y
+      REAL               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            V( 2 )
+*     ..
+*     .. External Functions ..
+      COMPLEX            CLADIV
+      REAL               SLAMCH
+      EXTERNAL           CLADIV, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLARFG, CSCAL, SLABAD
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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( AIMAG( 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 = CONJG( 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 CSCAL( JHI-I+1, SC, H( I, I ), LDH )
+            CALL CSCAL( MIN( JHI, I+1 )-JLO+1, CONJG( SC ), H( JLO, I ),
+     $                  1 )
+            IF( WANTZ )
+     $         CALL CSCAL( IHIZ-ILOZ+1, CONJG( 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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( REAL( H( K-1, K-2 ) ) )
+               IF( K+1.LE.IHI )
+     $            TST = TST + ABS( REAL( 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( REAL( 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( REAL( 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( REAL( X / SX )*REAL( Y )+AIMAG( X / SX )*
+     $                AIMAG( Y ).LT.RZERO )Y = -Y
+               END IF
+               T = T - U*CLADIV( 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 CLARFG, and hence
+*           after the call T2 ( = T1*V(2) ) is also real.
+*
+            IF( K.GT.M )
+     $         CALL CCOPY( 2, H( K, K-1 ), 1, V, 1 )
+            CALL CLARFG( 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 = REAL( 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 = CONJG( 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*CONJG( 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*CONJG( 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 )*CONJG( 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 CSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
+                     CALL CSCAL( J-I1, CONJG( TEMP ), H( I1, J ), 1 )
+                     IF( WANTZ ) THEN
+                        CALL CSCAL( NZ, CONJG( 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( AIMAG( TEMP ).NE.RZERO ) THEN
+            RTEMP = ABS( TEMP )
+            H( I, I-1 ) = RTEMP
+            TEMP = TEMP / RTEMP
+            IF( I2.GT.I )
+     $         CALL CSCAL( I2-I, CONJG( TEMP ), H( I, I+1 ), LDH )
+            CALL CSCAL( I-I1, TEMP, H( I1, I ), 1 )
+            IF( WANTZ ) THEN
+               CALL CSCAL( 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 CLAHQR
+*
+      END
diff --git a/SRC/clahr2.f b/SRC/clahr2.f
new file mode 100644
index 00000000..fcb49212
--- /dev/null
+++ b/SRC/clahr2.f
@@ -0,0 +1,240 @@
+      SUBROUTINE CLAHR2( 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            A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAHR2 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 CGEHRD.
+*
+*  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 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 array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) COMPLEX array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) COMPLEX 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 CLAHRD
+*  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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ), 
+     $                     ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMM, CGEMV, CLACPY,
+     $                   CLARFG, CSCAL, CTRMM, CTRMV, CLACGV
+*     ..
+*     .. 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 CLACGV( I-1, A( K+I-1, 1 ), LDA ) 
+            CALL CGEMV( '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 CLACGV( 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 CCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL CTRMV( 'Lower', 'Conjugate transpose', 'UNIT', 
+     $                  I-1, A( K+1, 1 ),
+     $                  LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL CGEMV( '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 CTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', 
+     $                  I-1, T, LDT,
+     $                  T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL CGEMV( '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 CTRMV( 'Lower', 'NO TRANSPOSE', 
+     $                  'UNIT', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL CAXPY( 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 CLARFG( 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 CGEMV( '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 CGEMV( '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 CGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, 
+     $               Y( K+1, 1 ), LDY,
+     $               T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
+         CALL CSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
+*
+*        Compute T(1:I,I)
+*
+         CALL CSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL CTRMV( '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 CLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
+      CALL CTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', 
+     $            'UNIT', K, NB,
+     $            ONE, A( K+1, 1 ), LDA, Y, LDY )
+      IF( N.GT.K+NB )
+     $   CALL CGEMM( '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 CTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', 
+     $            'NON-UNIT', K, NB,
+     $            ONE, T, LDT, Y, LDY )
+*
+      RETURN
+*
+*     End of CLAHR2
+*
+      END
diff --git a/SRC/clahrd.f b/SRC/clahrd.f
new file mode 100644
index 00000000..f8252e8b
--- /dev/null
+++ b/SRC/clahrd.f
@@ -0,0 +1,213 @@
+      SUBROUTINE CLAHRD( 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            A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAHRD 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 CLAHR2 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 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 array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) COMPLEX array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) COMPLEX 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMV, CLACGV, CLARFG, CSCAL,
+     $                   CTRMV
+*     ..
+*     .. 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 CLACGV( I-1, A( K+I-1, 1 ), LDA )
+            CALL CGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
+     $                  A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
+            CALL CLACGV( 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 CCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL CTRMV( 'Lower', 'Conjugate transpose', 'Unit', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL CGEMV( '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 CTRMV( 'Upper', 'Conjugate transpose', 'Non-unit', I-1,
+     $                  T, LDT, T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL CGEMV( '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 CTRMV( 'Lower', 'No transpose', 'Unit', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL CAXPY( 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 CLARFG( 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 CGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
+         CALL CGEMV( '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 CGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
+     $               ONE, Y( 1, I ), 1 )
+         CALL CSCAL( N, TAU( I ), Y( 1, I ), 1 )
+*
+*        Compute T(1:i,i)
+*
+         CALL CSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL CTRMV( '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 CLAHRD
+*
+      END
diff --git a/SRC/claic1.f b/SRC/claic1.f
new file mode 100644
index 00000000..a19ccb79
--- /dev/null
+++ b/SRC/claic1.f
@@ -0,0 +1,295 @@
+      SUBROUTINE CLAIC1( 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
+      REAL               SEST, SESTPR
+      COMPLEX            C, GAMMA, S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            W( J ), X( J )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAIC1 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 CLAIC1 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 array, dimension (J)
+*          The j-vector x.
+*
+*  SEST    (input) REAL
+*          Estimated singular value of j by j matrix L
+*
+*  W       (input) COMPLEX array, dimension (J)
+*          The j-vector w.
+*
+*  GAMMA   (input) COMPLEX
+*          The diagonal element gamma.
+*
+*  SESTPR  (output) REAL
+*          Estimated singular value of (j+1) by (j+1) matrix Lhat.
+*
+*  S       (output) COMPLEX
+*          Sine needed in forming xhat.
+*
+*  C       (output) COMPLEX
+*          Cosine needed in forming xhat.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+      REAL               HALF, FOUR
+      PARAMETER          ( HALF = 0.5E0, FOUR = 4.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               ABSALP, ABSEST, ABSGAM, B, EPS, NORMA, S1, S2,
+     $                   SCL, T, TEST, TMP, ZETA1, ZETA2
+      COMPLEX            ALPHA, COSINE, SINE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, SQRT
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      COMPLEX            CDOTC
+      EXTERNAL           SLAMCH, CDOTC
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = SLAMCH( 'Epsilon' )
+      ALPHA = CDOTC( 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*CONJG( S )+C*CONJG( 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*CONJG( SINE )+COSINE*CONJG( 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 = -CONJG( GAMMA )
+               COSINE = CONJG( ALPHA )
+            END IF
+            S1 = MAX( ABS( SINE ), ABS( COSINE ) )
+            S = SINE / S1
+            C = COSINE / S1
+            TMP = SQRT( S*CONJG( S )+C*CONJG( 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 = -( CONJG( GAMMA ) / S2 ) / SCL
+               C = ( CONJG( ALPHA ) / S2 ) / SCL
+            ELSE
+               TMP = S2 / S1
+               SCL = SQRT( ONE+TMP*TMP )
+               SESTPR = ABSEST / SCL
+               S = -( CONJG( GAMMA ) / S1 ) / SCL
+               C = ( CONJG( 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*CONJG( SINE )+COSINE*CONJG( COSINE ) )
+            S = SINE / TMP
+            C = COSINE / TMP
+            RETURN
+*
+         END IF
+      END IF
+      RETURN
+*
+*     End of CLAIC1
+*
+      END
diff --git a/SRC/clals0.f b/SRC/clals0.f
new file mode 100644
index 00000000..4786ea71
--- /dev/null
+++ b/SRC/clals0.f
@@ -0,0 +1,433 @@
+      SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
+     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
+     $                   POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
+     $                   LDGNUM, NL, NR, NRHS, SQRE
+      REAL               C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
+      REAL               DIFL( * ), DIFR( LDGNUM, * ),
+     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
+     $                   RWORK( * ), Z( * )
+      COMPLEX            B( LDB, * ), BX( LDBX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLALS0 applies back the multiplying factors of either the left or the
+*  right singular vector matrix of a diagonal matrix appended by a row
+*  to the right hand side matrix B in solving the least squares problem
+*  using the divide-and-conquer SVD approach.
+*
+*  For the left singular vector matrix, three types of orthogonal
+*  matrices are involved:
+*
+*  (1L) Givens rotations: the number of such rotations is GIVPTR; the
+*       pairs of columns/rows they were applied to are stored in GIVCOL;
+*       and the C- and S-values of these rotations are stored in GIVNUM.
+*
+*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
+*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the
+*       J-th row.
+*
+*  (3L) The left singular vector matrix of the remaining matrix.
+*
+*  For the right singular vector matrix, four types of orthogonal
+*  matrices are involved:
+*
+*  (1R) The right singular vector matrix of the remaining matrix.
+*
+*  (2R) If SQRE = 1, one extra Givens rotation to generate the right
+*       null space.
+*
+*  (3R) The inverse transformation of (2L).
+*
+*  (4R) The inverse transformation of (1L).
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed in
+*         factored form:
+*         = 0: Left singular vector matrix.
+*         = 1: Right singular vector matrix.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block. NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block. NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) COMPLEX array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M. On output, B contains
+*         the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B. LDB must be at least
+*         max(1,MAX( M, N ) ).
+*
+*  BX     (workspace) COMPLEX array, dimension ( LDBX, NRHS )
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  PERM   (input) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) applied
+*         to the two blocks.
+*
+*  GIVPTR (input) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of rows/columns
+*         involved in a Givens rotation.
+*
+*  LDGCOL (input) INTEGER
+*         The leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value used in the
+*         corresponding Givens rotation.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of arrays DIFR, POLES and
+*         GIVNUM, must be at least K.
+*
+*  POLES  (input) REAL array, dimension ( LDGNUM, 2 )
+*         On entry, POLES(1:K, 1) contains the new singular
+*         values obtained from solving the secular equation, and
+*         POLES(1:K, 2) is an array containing the poles in the secular
+*         equation.
+*
+*  DIFL   (input) REAL array, dimension ( K ).
+*         On entry, DIFL(I) is the distance between I-th updated
+*         (undeflated) singular value and the I-th (undeflated) old
+*         singular value.
+*
+*  DIFR   (input) REAL array, dimension ( LDGNUM, 2 ).
+*         On entry, DIFR(I, 1) contains the distances between I-th
+*         updated (undeflated) singular value and the I+1-th
+*         (undeflated) old singular value. And DIFR(I, 2) is the
+*         normalizing factor for the I-th right singular vector.
+*
+*  Z      (input) REAL array, dimension ( K )
+*         Contain the components of the deflation-adjusted updating row
+*         vector.
+*
+*  K      (input) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  C      (input) REAL
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (input) REAL
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  RWORK  (workspace) REAL array, dimension
+*         ( K*(1+NRHS) + 2*NRHS )
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JCOL, JROW, M, N, NLP1
+      REAL               DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CLASCL, CSROT, CSSCAL, SGEMV,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3, SNRM2
+      EXTERNAL           SLAMC3, SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      END IF
+*
+      N = NL + NR + 1
+*
+      IF( NRHS.LT.1 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -7
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -9
+      ELSE IF( GIVPTR.LT.0 ) THEN
+         INFO = -11
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -13
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -15
+      ELSE IF( K.LT.1 ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLALS0', -INFO )
+         RETURN
+      END IF
+*
+      M = N + SQRE
+      NLP1 = NL + 1
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+*
+*        Apply back orthogonal transformations from the left.
+*
+*        Step (1L): apply back the Givens rotations performed.
+*
+         DO 10 I = 1, GIVPTR
+            CALL CSROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                  GIVNUM( I, 1 ) )
+   10    CONTINUE
+*
+*        Step (2L): permute rows of B.
+*
+         CALL CCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
+         DO 20 I = 2, N
+            CALL CCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
+   20    CONTINUE
+*
+*        Step (3L): apply the inverse of the left singular vector
+*        matrix to BX.
+*
+         IF( K.EQ.1 ) THEN
+            CALL CCOPY( NRHS, BX, LDBX, B, LDB )
+            IF( Z( 1 ).LT.ZERO ) THEN
+               CALL CSSCAL( NRHS, NEGONE, B, LDB )
+            END IF
+         ELSE
+            DO 100 J = 1, K
+               DIFLJ = DIFL( J )
+               DJ = POLES( J, 1 )
+               DSIGJ = -POLES( J, 2 )
+               IF( J.LT.K ) THEN
+                  DIFRJ = -DIFR( J, 1 )
+                  DSIGJP = -POLES( J+1, 2 )
+               END IF
+               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
+     $              THEN
+                  RWORK( J ) = ZERO
+               ELSE
+                  RWORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
+     $                         ( POLES( J, 2 )+DJ )
+               END IF
+               DO 30 I = 1, J - 1
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                            ( SLAMC3( POLES( I, 2 ), DSIGJ )-
+     $                            DIFLJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   30          CONTINUE
+               DO 40 I = J + 1, K
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                            ( SLAMC3( POLES( I, 2 ), DSIGJP )+
+     $                            DIFRJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   40          CONTINUE
+               RWORK( 1 ) = NEGONE
+               TEMP = SNRM2( K, RWORK, 1 )
+*
+*              Since B and BX are complex, the following call to SGEMV
+*              is performed in two steps (real and imaginary parts).
+*
+*              CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
+*    $                     B( J, 1 ), LDB )
+*
+               I = K + NRHS*2
+               DO 60 JCOL = 1, NRHS
+                  DO 50 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = REAL( BX( JROW, JCOL ) )
+   50             CONTINUE
+   60          CONTINUE
+               CALL SGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
+               I = K + NRHS*2
+               DO 80 JCOL = 1, NRHS
+                  DO 70 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = AIMAG( BX( JROW, JCOL ) )
+   70             CONTINUE
+   80          CONTINUE
+               CALL SGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
+               DO 90 JCOL = 1, NRHS
+                  B( J, JCOL ) = CMPLX( RWORK( JCOL+K ),
+     $                           RWORK( JCOL+K+NRHS ) )
+   90          CONTINUE
+               CALL CLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
+     $                      LDB, INFO )
+  100       CONTINUE
+         END IF
+*
+*        Move the deflated rows of BX to B also.
+*
+         IF( K.LT.MAX( M, N ) )
+     $      CALL CLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
+     $                   B( K+1, 1 ), LDB )
+      ELSE
+*
+*        Apply back the right orthogonal transformations.
+*
+*        Step (1R): apply back the new right singular vector matrix
+*        to B.
+*
+         IF( K.EQ.1 ) THEN
+            CALL CCOPY( NRHS, B, LDB, BX, LDBX )
+         ELSE
+            DO 180 J = 1, K
+               DSIGJ = POLES( J, 2 )
+               IF( Z( J ).EQ.ZERO ) THEN
+                  RWORK( J ) = ZERO
+               ELSE
+                  RWORK( J ) = -Z( J ) / DIFL( J ) /
+     $                         ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
+               END IF
+               DO 110 I = 1, J - 1
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I+1,
+     $                            2 ) )-DIFR( I, 1 ) ) /
+     $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+  110          CONTINUE
+               DO 120 I = J + 1, K
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I,
+     $                            2 ) )-DIFL( I ) ) /
+     $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+  120          CONTINUE
+*
+*              Since B and BX are complex, the following call to SGEMV
+*              is performed in two steps (real and imaginary parts).
+*
+*              CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
+*    $                     BX( J, 1 ), LDBX )
+*
+               I = K + NRHS*2
+               DO 140 JCOL = 1, NRHS
+                  DO 130 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = REAL( B( JROW, JCOL ) )
+  130             CONTINUE
+  140          CONTINUE
+               CALL SGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
+               I = K + NRHS*2
+               DO 160 JCOL = 1, NRHS
+                  DO 150 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = AIMAG( B( JROW, JCOL ) )
+  150             CONTINUE
+  160          CONTINUE
+               CALL SGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
+               DO 170 JCOL = 1, NRHS
+                  BX( J, JCOL ) = CMPLX( RWORK( JCOL+K ),
+     $                            RWORK( JCOL+K+NRHS ) )
+  170          CONTINUE
+  180       CONTINUE
+         END IF
+*
+*        Step (2R): if SQRE = 1, apply back the rotation that is
+*        related to the right null space of the subproblem.
+*
+         IF( SQRE.EQ.1 ) THEN
+            CALL CCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
+            CALL CSROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
+         END IF
+         IF( K.LT.MAX( M, N ) )
+     $      CALL CLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB,
+     $                   BX( K+1, 1 ), LDBX )
+*
+*        Step (3R): permute rows of B.
+*
+         CALL CCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
+         IF( SQRE.EQ.1 ) THEN
+            CALL CCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
+         END IF
+         DO 190 I = 2, N
+            CALL CCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
+  190    CONTINUE
+*
+*        Step (4R): apply back the Givens rotations performed.
+*
+         DO 200 I = GIVPTR, 1, -1
+            CALL CSROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                  -GIVNUM( I, 1 ) )
+  200    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CLALS0
+*
+      END
diff --git a/SRC/clalsa.f b/SRC/clalsa.f
new file mode 100644
index 00000000..8938fac1
--- /dev/null
+++ b/SRC/clalsa.f
@@ -0,0 +1,503 @@
+      SUBROUTINE CLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
+     $                   LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
+     $                   GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
+     $                   SMLSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+     $                   K( * ), PERM( LDGCOL, * )
+      REAL               C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
+     $                   GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
+     $                   S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
+      COMPLEX            B( LDB, * ), BX( LDBX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLALSA is an itermediate step in solving the least squares problem
+*  by computing the SVD of the coefficient matrix in compact form (The
+*  singular vectors are computed as products of simple orthorgonal
+*  matrices.).
+*
+*  If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector
+*  matrix of an upper bidiagonal matrix to the right hand side; and if
+*  ICOMPQ = 1, CLALSA applies the right singular vector matrix to the
+*  right hand side. The singular vector matrices were generated in
+*  compact form by CLALSA.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether the left or the right singular vector
+*         matrix is involved.
+*         = 0: Left singular vector matrix
+*         = 1: Right singular vector matrix
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The row and column dimensions of the upper bidiagonal matrix.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) COMPLEX array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M.
+*         On output, B contains the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,MAX( M, N ) ).
+*
+*  BX     (output) COMPLEX array, dimension ( LDBX, NRHS )
+*         On exit, the result of applying the left or right singular
+*         vector matrix to B.
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  U      (input) REAL array, dimension ( LDU, SMLSIZ ).
+*         On entry, U contains the left singular vector matrices of all
+*         subproblems at the bottom level.
+*
+*  LDU    (input) INTEGER, LDU = > N.
+*         The leading dimension of arrays U, VT, DIFL, DIFR,
+*         POLES, GIVNUM, and Z.
+*
+*  VT     (input) REAL array, dimension ( LDU, SMLSIZ+1 ).
+*         On entry, VT' contains the right singular vector matrices of
+*         all subproblems at the bottom level.
+*
+*  K      (input) INTEGER array, dimension ( N ).
+*
+*  DIFL   (input) REAL array, dimension ( LDU, NLVL ).
+*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
+*
+*  DIFR   (input) REAL array, dimension ( LDU, 2 * NLVL ).
+*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
+*         distances between singular values on the I-th level and
+*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
+*         record the normalizing factors of the right singular vectors
+*         matrices of subproblems on I-th level.
+*
+*  Z      (input) REAL array, dimension ( LDU, NLVL ).
+*         On entry, Z(1, I) contains the components of the deflation-
+*         adjusted updating row vector for subproblems on the I-th
+*         level.
+*
+*  POLES  (input) REAL array, dimension ( LDU, 2 * NLVL ).
+*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
+*         singular values involved in the secular equations on the I-th
+*         level.
+*
+*  GIVPTR (input) INTEGER array, dimension ( N ).
+*         On entry, GIVPTR( I ) records the number of Givens
+*         rotations performed on the I-th problem on the computation
+*         tree.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
+*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
+*         locations of Givens rotations performed on the I-th level on
+*         the computation tree.
+*
+*  LDGCOL (input) INTEGER, LDGCOL = > N.
+*         The leading dimension of arrays GIVCOL and PERM.
+*
+*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).
+*         On entry, PERM(*, I) records permutations done on the I-th
+*         level of the computation tree.
+*
+*  GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).
+*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
+*         values of Givens rotations performed on the I-th level on the
+*         computation tree.
+*
+*  C      (input) REAL array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         C( I ) contains the C-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  S      (input) REAL array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         S( I ) contains the S-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  RWORK  (workspace) REAL array, dimension at least
+*         max ( N, (SMLSZ+1)*NRHS*3 ).
+*
+*  IWORK  (workspace) INTEGER array.
+*         The dimension must be at least 3 * 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
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IM1, INODE, J, JCOL, JIMAG, JREAL,
+     $                   JROW, LF, LL, LVL, LVL2, ND, NDB1, NDIML,
+     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQRE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLALS0, SGEMM, SLASDT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.SMLSIZ ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -6
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -8
+      ELSE IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -19
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLALSA', -INFO )
+         RETURN
+      END IF
+*
+*     Book-keeping and  setting up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+*
+      CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     The following code applies back the left singular vector factors.
+*     For applying back the right singular vector factors, go to 170.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         GO TO 170
+      END IF
+*
+*     The nodes on the bottom level of the tree were solved
+*     by SLASDQ. The corresponding left and right singular vector
+*     matrices are in explicit form. First apply back the left
+*     singular vector matrices.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 130 I = NDB1, ND
+*
+*        IC : center row of each node
+*        NL : number of rows of left  subproblem
+*        NR : number of rows of right subproblem
+*        NLF: starting row of the left   subproblem
+*        NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLF = IC - NL
+         NRF = IC + 1
+*
+*        Since B and BX are complex, the following call to SGEMM
+*        is performed in two steps (real and imaginary parts).
+*
+*        CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+*     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+*
+         J = NL*NRHS*2
+         DO 20 JCOL = 1, NRHS
+            DO 10 JROW = NLF, NLF + NL - 1
+               J = J + 1
+               RWORK( J ) = REAL( B( JROW, JCOL ) )
+   10       CONTINUE
+   20    CONTINUE
+         CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+     $               RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1 ), NL )
+         J = NL*NRHS*2
+         DO 40 JCOL = 1, NRHS
+            DO 30 JROW = NLF, NLF + NL - 1
+               J = J + 1
+               RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+   30       CONTINUE
+   40    CONTINUE
+         CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+     $               RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1+NL*NRHS ),
+     $               NL )
+         JREAL = 0
+         JIMAG = NL*NRHS
+         DO 60 JCOL = 1, NRHS
+            DO 50 JROW = NLF, NLF + NL - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = CMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+   50       CONTINUE
+   60    CONTINUE
+*
+*        Since B and BX are complex, the following call to SGEMM
+*        is performed in two steps (real and imaginary parts).
+*
+*        CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+*    $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+*
+         J = NR*NRHS*2
+         DO 80 JCOL = 1, NRHS
+            DO 70 JROW = NRF, NRF + NR - 1
+               J = J + 1
+               RWORK( J ) = REAL( B( JROW, JCOL ) )
+   70       CONTINUE
+   80    CONTINUE
+         CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+     $               RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1 ), NR )
+         J = NR*NRHS*2
+         DO 100 JCOL = 1, NRHS
+            DO 90 JROW = NRF, NRF + NR - 1
+               J = J + 1
+               RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+   90       CONTINUE
+  100    CONTINUE
+         CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+     $               RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1+NR*NRHS ),
+     $               NR )
+         JREAL = 0
+         JIMAG = NR*NRHS
+         DO 120 JCOL = 1, NRHS
+            DO 110 JROW = NRF, NRF + NR - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = CMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+  110       CONTINUE
+  120    CONTINUE
+*
+  130 CONTINUE
+*
+*     Next copy the rows of B that correspond to unchanged rows
+*     in the bidiagonal matrix to BX.
+*
+      DO 140 I = 1, ND
+         IC = IWORK( INODE+I-1 )
+         CALL CCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
+  140 CONTINUE
+*
+*     Finally go through the left singular vector matrices of all
+*     the other subproblems bottom-up on the tree.
+*
+      J = 2**NLVL
+      SQRE = 0
+*
+      DO 160 LVL = NLVL, 1, -1
+         LVL2 = 2*LVL - 1
+*
+*        find the first node LF and last node LL on
+*        the current level LVL
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 150 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            J = J - 1
+            CALL CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
+     $                   B( NLF, 1 ), LDB, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
+     $                   INFO )
+  150    CONTINUE
+  160 CONTINUE
+      GO TO 330
+*
+*     ICOMPQ = 1: applying back the right singular vector factors.
+*
+  170 CONTINUE
+*
+*     First now go through the right singular vector matrices of all
+*     the tree nodes top-down.
+*
+      J = 0
+      DO 190 LVL = 1, NLVL
+         LVL2 = 2*LVL - 1
+*
+*        Find the first node LF and last node LL on
+*        the current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 180 I = LL, LF, -1
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            IF( I.EQ.LL ) THEN
+               SQRE = 0
+            ELSE
+               SQRE = 1
+            END IF
+            J = J + 1
+            CALL CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
+     $                   BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
+     $                   INFO )
+  180    CONTINUE
+  190 CONTINUE
+*
+*     The nodes on the bottom level of the tree were solved
+*     by SLASDQ. The corresponding right singular vector
+*     matrices are in explicit form. Apply them back.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 320 I = NDB1, ND
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLP1 = NL + 1
+         IF( I.EQ.ND ) THEN
+            NRP1 = NR
+         ELSE
+            NRP1 = NR + 1
+         END IF
+         NLF = IC - NL
+         NRF = IC + 1
+*
+*        Since B and BX are complex, the following call to SGEMM is
+*        performed in two steps (real and imaginary parts).
+*
+*        CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+*    $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+*
+         J = NLP1*NRHS*2
+         DO 210 JCOL = 1, NRHS
+            DO 200 JROW = NLF, NLF + NLP1 - 1
+               J = J + 1
+               RWORK( J ) = REAL( B( JROW, JCOL ) )
+  200       CONTINUE
+  210    CONTINUE
+         CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+     $               RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO, RWORK( 1 ),
+     $               NLP1 )
+         J = NLP1*NRHS*2
+         DO 230 JCOL = 1, NRHS
+            DO 220 JROW = NLF, NLF + NLP1 - 1
+               J = J + 1
+               RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+  220       CONTINUE
+  230    CONTINUE
+         CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+     $               RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO,
+     $               RWORK( 1+NLP1*NRHS ), NLP1 )
+         JREAL = 0
+         JIMAG = NLP1*NRHS
+         DO 250 JCOL = 1, NRHS
+            DO 240 JROW = NLF, NLF + NLP1 - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = CMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+  240       CONTINUE
+  250    CONTINUE
+*
+*        Since B and BX are complex, the following call to SGEMM is
+*        performed in two steps (real and imaginary parts).
+*
+*        CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+*    $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+*
+         J = NRP1*NRHS*2
+         DO 270 JCOL = 1, NRHS
+            DO 260 JROW = NRF, NRF + NRP1 - 1
+               J = J + 1
+               RWORK( J ) = REAL( B( JROW, JCOL ) )
+  260       CONTINUE
+  270    CONTINUE
+         CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+     $               RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO, RWORK( 1 ),
+     $               NRP1 )
+         J = NRP1*NRHS*2
+         DO 290 JCOL = 1, NRHS
+            DO 280 JROW = NRF, NRF + NRP1 - 1
+               J = J + 1
+               RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+  280       CONTINUE
+  290    CONTINUE
+         CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+     $               RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO,
+     $               RWORK( 1+NRP1*NRHS ), NRP1 )
+         JREAL = 0
+         JIMAG = NRP1*NRHS
+         DO 310 JCOL = 1, NRHS
+            DO 300 JROW = NRF, NRF + NRP1 - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = CMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+  300       CONTINUE
+  310    CONTINUE
+*
+  320 CONTINUE
+*
+  330 CONTINUE
+*
+      RETURN
+*
+*     End of CLALSA
+*
+      END
diff --git a/SRC/clalsd.f b/SRC/clalsd.f
new file mode 100644
index 00000000..01b7a31c
--- /dev/null
+++ b/SRC/clalsd.f
@@ -0,0 +1,596 @@
+      SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
+     $                   RANK, WORK, RWORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), RWORK( * )
+      COMPLEX            B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLALSD uses the singular value decomposition of A to solve the least
+*  squares problem of finding X to minimize the Euclidean norm of each
+*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
+*  are N-by-NRHS. The solution X overwrites B.
+*
+*  The singular values of A smaller than RCOND times the largest
+*  singular value are treated as zero in solving the least squares
+*  problem; in this case a minimum norm solution is returned.
+*  The actual singular values are returned in D in ascending order.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  UPLO   (input) CHARACTER*1
+*         = 'U': D and E define an upper bidiagonal matrix.
+*         = 'L': D and E define a  lower bidiagonal matrix.
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The dimension of the  bidiagonal matrix.  N >= 0.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B. NRHS must be at least 1.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix. On exit, if INFO = 0, D contains its singular values.
+*
+*  E      (input/output) REAL array, dimension (N-1)
+*         Contains the super-diagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  B      (input/output) COMPLEX array, dimension (LDB,NRHS)
+*         On input, B contains the right hand sides of the least
+*         squares problem. On output, B contains the solution X.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,N).
+*
+*  RCOND  (input) REAL
+*         The singular values of A less than or equal to RCOND times
+*         the largest singular value are treated as zero in solving
+*         the least squares problem. If RCOND is negative,
+*         machine precision is used instead.
+*         For example, if diag(S)*X=B were the least squares problem,
+*         where diag(S) is a diagonal matrix of singular values, the
+*         solution would be X(i) = B(i) / S(i) if S(i) is greater than
+*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
+*         RCOND*max(S).
+*
+*  RANK   (output) INTEGER
+*         The number of singular values of A greater than RCOND times
+*         the largest singular value.
+*
+*  WORK   (workspace) COMPLEX array, dimension (N * NRHS).
+*
+*  RWORK  (workspace) REAL array, dimension at least
+*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2),
+*         where
+*         NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+*
+*  IWORK  (workspace) INTEGER array, dimension (3*N*NLVL + 11*N).
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*         > 0:  The algorithm failed to compute an singular value while
+*               working on the submatrix lying in rows and columns
+*               INFO/(N+1) through MOD(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
+     $                   GIVPTR, I, ICMPQ1, ICMPQ2, IRWB, IRWIB, IRWRB,
+     $                   IRWU, IRWVT, IRWWRK, IWK, J, JCOL, JIMAG,
+     $                   JREAL, JROW, K, NLVL, NM1, NRWORK, NSIZE, NSUB,
+     $                   PERM, POLES, S, SIZEI, SMLSZP, SQRE, ST, ST1,
+     $                   U, VT, Z
+      REAL               CS, EPS, ORGNRM, R, RCND, SN, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLANST
+      EXTERNAL           ISAMAX, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CLALSA, CLASCL, CLASET, CSROT,
+     $                   SGEMM, SLARTG, SLASCL, SLASDA, SLASDQ, SLASET,
+     $                   SLASRT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, INT, LOG, REAL, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLALSD', -INFO )
+         RETURN
+      END IF
+*
+      EPS = SLAMCH( 'Epsilon' )
+*
+*     Set up the tolerance.
+*
+      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
+         RCND = EPS
+      ELSE
+         RCND = RCOND
+      END IF
+*
+      RANK = 0
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         IF( D( 1 ).EQ.ZERO ) THEN
+            CALL CLASET( 'A', 1, NRHS, CZERO, CZERO, B, LDB )
+         ELSE
+            RANK = 1
+            CALL CLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
+            D( 1 ) = ABS( D( 1 ) )
+         END IF
+         RETURN
+      END IF
+*
+*     Rotate the matrix if it is lower bidiagonal.
+*
+      IF( UPLO.EQ.'L' ) THEN
+         DO 10 I = 1, N - 1
+            CALL SLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( NRHS.EQ.1 ) THEN
+               CALL CSROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
+            ELSE
+               RWORK( I*2-1 ) = CS
+               RWORK( I*2 ) = SN
+            END IF
+   10    CONTINUE
+         IF( NRHS.GT.1 ) THEN
+            DO 30 I = 1, NRHS
+               DO 20 J = 1, N - 1
+                  CS = RWORK( J*2-1 )
+                  SN = RWORK( J*2 )
+                  CALL CSROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
+   20          CONTINUE
+   30       CONTINUE
+         END IF
+      END IF
+*
+*     Scale.
+*
+      NM1 = N - 1
+      ORGNRM = SLANST( 'M', N, D, E )
+      IF( ORGNRM.EQ.ZERO ) THEN
+         CALL CLASET( 'A', N, NRHS, CZERO, CZERO, B, LDB )
+         RETURN
+      END IF
+*
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
+*
+*     If N is smaller than the minimum divide size SMLSIZ, then solve
+*     the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         IRWU = 1
+         IRWVT = IRWU + N*N
+         IRWWRK = IRWVT + N*N
+         IRWRB = IRWWRK
+         IRWIB = IRWRB + N*NRHS
+         IRWB = IRWIB + N*NRHS
+         CALL SLASET( 'A', N, N, ZERO, ONE, RWORK( IRWU ), N )
+         CALL SLASET( 'A', N, N, ZERO, ONE, RWORK( IRWVT ), N )
+         CALL SLASDQ( 'U', 0, N, N, N, 0, D, E, RWORK( IRWVT ), N,
+     $                RWORK( IRWU ), N, RWORK( IRWWRK ), 1,
+     $                RWORK( IRWWRK ), INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+*
+*        In the real version, B is passed to SLASDQ and multiplied
+*        internally by Q'. Here B is complex and that product is
+*        computed below in two steps (real and imaginary parts).
+*
+         J = IRWB - 1
+         DO 50 JCOL = 1, NRHS
+            DO 40 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = REAL( B( JROW, JCOL ) )
+   40       CONTINUE
+   50    CONTINUE
+         CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
+         J = IRWB - 1
+         DO 70 JCOL = 1, NRHS
+            DO 60 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+   60       CONTINUE
+   70    CONTINUE
+         CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
+         JREAL = IRWRB - 1
+         JIMAG = IRWIB - 1
+         DO 90 JCOL = 1, NRHS
+            DO 80 JROW = 1, N
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               B( JROW, JCOL ) = CMPLX( RWORK( JREAL ), RWORK( JIMAG ) )
+   80       CONTINUE
+   90    CONTINUE
+*
+         TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
+         DO 100 I = 1, N
+            IF( D( I ).LE.TOL ) THEN
+               CALL CLASET( 'A', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            ELSE
+               CALL CLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
+     $                      LDB, INFO )
+               RANK = RANK + 1
+            END IF
+  100    CONTINUE
+*
+*        Since B is complex, the following call to SGEMM is performed
+*        in two steps (real and imaginary parts). That is for V * B
+*        (in the real version of the code V' is stored in WORK).
+*
+*        CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
+*    $               WORK( NWORK ), N )
+*
+         J = IRWB - 1
+         DO 120 JCOL = 1, NRHS
+            DO 110 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = REAL( B( JROW, JCOL ) )
+  110       CONTINUE
+  120    CONTINUE
+         CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
+         J = IRWB - 1
+         DO 140 JCOL = 1, NRHS
+            DO 130 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+  130       CONTINUE
+  140    CONTINUE
+         CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
+         JREAL = IRWRB - 1
+         JIMAG = IRWIB - 1
+         DO 160 JCOL = 1, NRHS
+            DO 150 JROW = 1, N
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               B( JROW, JCOL ) = CMPLX( RWORK( JREAL ), RWORK( JIMAG ) )
+  150       CONTINUE
+  160    CONTINUE
+*
+*        Unscale.
+*
+         CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+         CALL SLASRT( 'D', N, D, INFO )
+         CALL CLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+         RETURN
+      END IF
+*
+*     Book-keeping and setting up some constants.
+*
+      NLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+*
+      SMLSZP = SMLSIZ + 1
+*
+      U = 1
+      VT = 1 + SMLSIZ*N
+      DIFL = VT + SMLSZP*N
+      DIFR = DIFL + NLVL*N
+      Z = DIFR + NLVL*N*2
+      C = Z + NLVL*N
+      S = C + N
+      POLES = S + N
+      GIVNUM = POLES + 2*NLVL*N
+      NRWORK = GIVNUM + 2*NLVL*N
+      BX = 1
+*
+      IRWRB = NRWORK
+      IRWIB = IRWRB + SMLSIZ*NRHS
+      IRWB = IRWIB + SMLSIZ*NRHS
+*
+      SIZEI = 1 + N
+      K = SIZEI + N
+      GIVPTR = K + N
+      PERM = GIVPTR + N
+      GIVCOL = PERM + NLVL*N
+      IWK = GIVCOL + NLVL*N*2
+*
+      ST = 1
+      SQRE = 0
+      ICMPQ1 = 1
+      ICMPQ2 = 0
+      NSUB = 0
+*
+      DO 170 I = 1, N
+         IF( ABS( D( I ) ).LT.EPS ) THEN
+            D( I ) = SIGN( EPS, D( I ) )
+         END IF
+  170 CONTINUE
+*
+      DO 240 I = 1, NM1
+         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+            NSUB = NSUB + 1
+            IWORK( NSUB ) = ST
+*
+*           Subproblem found. First determine its size and then
+*           apply divide and conquer on it.
+*
+            IF( I.LT.NM1 ) THEN
+*
+*              A subproblem with E(I) small for I < NM1.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+*              A subproblem with E(NM1) not too small but I = NM1.
+*
+               NSIZE = N - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE
+*
+*              A subproblem with E(NM1) small. This implies an
+*              1-by-1 subproblem at D(N), which is not solved
+*              explicitly.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+               NSUB = NSUB + 1
+               IWORK( NSUB ) = N
+               IWORK( SIZEI+NSUB-1 ) = 1
+               CALL CCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
+            END IF
+            ST1 = ST - 1
+            IF( NSIZE.EQ.1 ) THEN
+*
+*              This is a 1-by-1 subproblem and is not solved
+*              explicitly.
+*
+               CALL CCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
+            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+*              This is a small subproblem and is solved by SLASDQ.
+*
+               CALL SLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+     $                      RWORK( VT+ST1 ), N )
+               CALL SLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+     $                      RWORK( U+ST1 ), N )
+               CALL SLASDQ( 'U', 0, NSIZE, NSIZE, NSIZE, 0, D( ST ),
+     $                      E( ST ), RWORK( VT+ST1 ), N, RWORK( U+ST1 ),
+     $                      N, RWORK( NRWORK ), 1, RWORK( NRWORK ),
+     $                      INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+*
+*              In the real version, B is passed to SLASDQ and multiplied
+*              internally by Q'. Here B is complex and that product is
+*              computed below in two steps (real and imaginary parts).
+*
+               J = IRWB - 1
+               DO 190 JCOL = 1, NRHS
+                  DO 180 JROW = ST, ST + NSIZE - 1
+                     J = J + 1
+                     RWORK( J ) = REAL( B( JROW, JCOL ) )
+  180             CONTINUE
+  190          CONTINUE
+               CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                     RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
+     $                     ZERO, RWORK( IRWRB ), NSIZE )
+               J = IRWB - 1
+               DO 210 JCOL = 1, NRHS
+                  DO 200 JROW = ST, ST + NSIZE - 1
+                     J = J + 1
+                     RWORK( J ) = AIMAG( B( JROW, JCOL ) )
+  200             CONTINUE
+  210          CONTINUE
+               CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                     RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
+     $                     ZERO, RWORK( IRWIB ), NSIZE )
+               JREAL = IRWRB - 1
+               JIMAG = IRWIB - 1
+               DO 230 JCOL = 1, NRHS
+                  DO 220 JROW = ST, ST + NSIZE - 1
+                     JREAL = JREAL + 1
+                     JIMAG = JIMAG + 1
+                     B( JROW, JCOL ) = CMPLX( RWORK( JREAL ),
+     $                                 RWORK( JIMAG ) )
+  220             CONTINUE
+  230          CONTINUE
+*
+               CALL CLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
+     $                      WORK( BX+ST1 ), N )
+            ELSE
+*
+*              A large problem. Solve it using divide and conquer.
+*
+               CALL SLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
+     $                      E( ST ), RWORK( U+ST1 ), N, RWORK( VT+ST1 ),
+     $                      IWORK( K+ST1 ), RWORK( DIFL+ST1 ),
+     $                      RWORK( DIFR+ST1 ), RWORK( Z+ST1 ),
+     $                      RWORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
+     $                      IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
+     $                      RWORK( GIVNUM+ST1 ), RWORK( C+ST1 ),
+     $                      RWORK( S+ST1 ), RWORK( NRWORK ),
+     $                      IWORK( IWK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+               BXST = BX + ST1
+               CALL CLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
+     $                      LDB, WORK( BXST ), N, RWORK( U+ST1 ), N,
+     $                      RWORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                      RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
+     $                      RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
+     $                      IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                      IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
+     $                      RWORK( C+ST1 ), RWORK( S+ST1 ),
+     $                      RWORK( NRWORK ), IWORK( IWK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+            END IF
+            ST = I + 1
+         END IF
+  240 CONTINUE
+*
+*     Apply the singular values and treat the tiny ones as zero.
+*
+      TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
+*
+      DO 250 I = 1, N
+*
+*        Some of the elements in D can be negative because 1-by-1
+*        subproblems were not solved explicitly.
+*
+         IF( ABS( D( I ) ).LE.TOL ) THEN
+            CALL CLASET( 'A', 1, NRHS, CZERO, CZERO, WORK( BX+I-1 ), N )
+         ELSE
+            RANK = RANK + 1
+            CALL CLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
+     $                   WORK( BX+I-1 ), N, INFO )
+         END IF
+         D( I ) = ABS( D( I ) )
+  250 CONTINUE
+*
+*     Now apply back the right singular vectors.
+*
+      ICMPQ2 = 1
+      DO 320 I = 1, NSUB
+         ST = IWORK( I )
+         ST1 = ST - 1
+         NSIZE = IWORK( SIZEI+I-1 )
+         BXST = BX + ST1
+         IF( NSIZE.EQ.1 ) THEN
+            CALL CCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
+         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+*           Since B and BX are complex, the following call to SGEMM
+*           is performed in two steps (real and imaginary parts).
+*
+*           CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+*    $                  RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO,
+*    $                  B( ST, 1 ), LDB )
+*
+            J = BXST - N - 1
+            JREAL = IRWB - 1
+            DO 270 JCOL = 1, NRHS
+               J = J + N
+               DO 260 JROW = 1, NSIZE
+                  JREAL = JREAL + 1
+                  RWORK( JREAL ) = REAL( WORK( J+JROW ) )
+  260          CONTINUE
+  270       CONTINUE
+            CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                  RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
+     $                  RWORK( IRWRB ), NSIZE )
+            J = BXST - N - 1
+            JIMAG = IRWB - 1
+            DO 290 JCOL = 1, NRHS
+               J = J + N
+               DO 280 JROW = 1, NSIZE
+                  JIMAG = JIMAG + 1
+                  RWORK( JIMAG ) = AIMAG( WORK( J+JROW ) )
+  280          CONTINUE
+  290       CONTINUE
+            CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                  RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
+     $                  RWORK( IRWIB ), NSIZE )
+            JREAL = IRWRB - 1
+            JIMAG = IRWIB - 1
+            DO 310 JCOL = 1, NRHS
+               DO 300 JROW = ST, ST + NSIZE - 1
+                  JREAL = JREAL + 1
+                  JIMAG = JIMAG + 1
+                  B( JROW, JCOL ) = CMPLX( RWORK( JREAL ),
+     $                              RWORK( JIMAG ) )
+  300          CONTINUE
+  310       CONTINUE
+         ELSE
+            CALL CLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
+     $                   B( ST, 1 ), LDB, RWORK( U+ST1 ), N,
+     $                   RWORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                   RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
+     $                   RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
+     $                   IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                   IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
+     $                   RWORK( C+ST1 ), RWORK( S+ST1 ),
+     $                   RWORK( NRWORK ), IWORK( IWK ), INFO )
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+         END IF
+  320 CONTINUE
+*
+*     Unscale and sort the singular values.
+*
+      CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+      CALL SLASRT( 'D', N, D, INFO )
+      CALL CLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+      RETURN
+*
+*     End of CLALSD
+*
+      END
diff --git a/SRC/clangb.f b/SRC/clangb.f
new file mode 100644
index 00000000..78210843
--- /dev/null
+++ b/SRC/clangb.f
@@ -0,0 +1,154 @@
+      REAL             FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB,
+     $                 WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            KL, KU, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               WORK( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANGB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  CLANGB returns the value
+*
+*     CLANGB = ( 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 CLANGB as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, CLANGB is
+*          set to zero.
+*
+*  KL      (input) INTEGER
+*          The number of sub-diagonals of the matrix A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of super-diagonals of the matrix A.  KU >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, K, L
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         DO 20 J = 1, N
+            DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               VALUE = MAX( VALUE, ABS( AB( 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               SUM = SUM + ABS( AB( 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
+            K = KU + 1 - J
+            DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
+               WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, N
+            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
+            L = MAX( 1, J-KU )
+            K = KU + 1 - J + L
+            CALL CLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANGB = VALUE
+      RETURN
+*
+*     End of CLANGB
+*
+      END
diff --git a/SRC/clange.f b/SRC/clange.f
new file mode 100644
index 00000000..a08ec756
--- /dev/null
+++ b/SRC/clange.f
@@ -0,0 +1,145 @@
+      REAL             FUNCTION CLANGE( 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 ..
+      REAL               WORK( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANGE  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
+*  ===========
+*
+*  CLANGE returns the value
+*
+*     CLANGE = ( 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 CLANGE as described
+*          above.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.  When M = 0,
+*          CLANGE is set to zero.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.  When N = 0,
+*          CLANGE is set to zero.
+*
+*  A       (input) COMPLEX 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. 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 CLASSQ( M, A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANGE = VALUE
+      RETURN
+*
+*     End of CLANGE
+*
+      END
diff --git a/SRC/clangt.f b/SRC/clangt.f
new file mode 100644
index 00000000..4e2e1ceb
--- /dev/null
+++ b/SRC/clangt.f
@@ -0,0 +1,141 @@
+      REAL             FUNCTION CLANGT( NORM, N, DL, D, DU )
+*
+*  -- 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 ..
+      COMPLEX            D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANGT  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 tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  CLANGT returns the value
+*
+*     CLANGT = ( 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 CLANGT as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, CLANGT is
+*          set to zero.
+*
+*  DL      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of A.
+*
+*  D       (input) COMPLEX array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) super-diagonal elements of A.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               ANORM, SCALE, SUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. 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( DL( I ) ) )
+            ANORM = MAX( ANORM, ABS( D( I ) ) )
+            ANORM = MAX( ANORM, ABS( DU( I ) ) )
+   10    CONTINUE
+      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
+*
+*        Find norm1(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
+     $              ABS( D( N ) )+ABS( DU( N-1 ) ) )
+            DO 20 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
+     $                 ABS( DU( I-1 ) ) )
+   20       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
+     $              ABS( D( N ) )+ABS( DL( N-1 ) ) )
+            DO 30 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
+     $                 ABS( DL( I-1 ) ) )
+   30       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         CALL CLASSQ( N, D, 1, SCALE, SUM )
+         IF( N.GT.1 ) THEN
+            CALL CLASSQ( N-1, DL, 1, SCALE, SUM )
+            CALL CLASSQ( N-1, DU, 1, SCALE, SUM )
+         END IF
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANGT = ANORM
+      RETURN
+*
+*     End of CLANGT
+*
+      END
diff --git a/SRC/clanhb.f b/SRC/clanhb.f
new file mode 100644
index 00000000..842228e8
--- /dev/null
+++ b/SRC/clanhb.f
@@ -0,0 +1,201 @@
+      REAL             FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB,
+     $                 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               WORK( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANHB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n hermitian band matrix A,  with k super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  CLANHB returns the value
+*
+*     CLANHB = ( 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 CLANHB as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          band matrix A is supplied.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, CLANHB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals or sub-diagonals of the
+*          band matrix A.  K >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangle of the hermitian band matrix A,
+*          stored in the first K+1 rows of AB.  The j-th column of A is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*          Note that the imaginary parts of the diagonal elements need
+*          not be set and are assumed to be zero.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = MAX( K+2-J, 1 ), K
+                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10          CONTINUE
+               VALUE = MAX( VALUE, ABS( REAL( AB( K+1, J ) ) ) )
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               VALUE = MAX( VALUE, ABS( REAL( AB( 1, J ) ) ) )
+               DO 30 I = 2, MIN( N+1-J, K+1 )
+                  VALUE = MAX( VALUE, ABS( AB( 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
+               L = K + 1 - J
+               DO 50 I = MAX( 1, J-K ), J - 1
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( REAL( AB( K+1, 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( REAL( AB( 1, J ) ) )
+               L = 1 - J
+               DO 90 I = J + 1, MIN( N, J+K )
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               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( K.GT.0 ) THEN
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 110 J = 2, N
+                  CALL CLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  110          CONTINUE
+               L = K + 1
+            ELSE
+               DO 120 J = 1, N - 1
+                  CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                         SUM )
+  120          CONTINUE
+               L = 1
+            END IF
+            SUM = 2*SUM
+         ELSE
+            L = 1
+         END IF
+         DO 130 J = 1, N
+            IF( REAL( AB( L, J ) ).NE.ZERO ) THEN
+               ABSA = ABS( REAL( AB( L, J ) ) )
+               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
+*
+      CLANHB = VALUE
+      RETURN
+*
+*     End of CLANHB
+*
+      END
diff --git a/SRC/clanhe.f b/SRC/clanhe.f
new file mode 100644
index 00000000..02155632
--- /dev/null
+++ b/SRC/clanhe.f
@@ -0,0 +1,187 @@
+      REAL             FUNCTION CLANHE( 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 ..
+      REAL               WORK( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANHE  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
+*  ===========
+*
+*  CLANHE returns the value
+*
+*     CLANHE = ( 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 CLANHE 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, CLANHE is
+*          set to zero.
+*
+*  A       (input) COMPLEX 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, REAL, 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( REAL( A( J, J ) ) ) )
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               VALUE = MAX( VALUE, ABS( REAL( 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( REAL( 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( REAL( 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 CLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL CLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+  120       CONTINUE
+         END IF
+         SUM = 2*SUM
+         DO 130 I = 1, N
+            IF( REAL( A( I, I ) ).NE.ZERO ) THEN
+               ABSA = ABS( REAL( 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
+*
+      CLANHE = VALUE
+      RETURN
+*
+*     End of CLANHE
+*
+      END
diff --git a/SRC/clanhp.f b/SRC/clanhp.f
new file mode 100644
index 00000000..e4aca0bd
--- /dev/null
+++ b/SRC/clanhp.f
@@ -0,0 +1,201 @@
+      REAL             FUNCTION CLANHP( 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 ..
+      REAL               WORK( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANHP  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,  supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  CLANHP returns the value
+*
+*     CLANHP = ( 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 CLANHP as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          hermitian 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, CLANHP is
+*          set to zero.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the hermitian matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          Note that the  imaginary parts of the diagonal elements need
+*          not be set and are assumed to be zero.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, K
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, REAL, 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 = 0
+            DO 20 J = 1, N
+               DO 10 I = K + 1, K + J - 1
+                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10          CONTINUE
+               K = K + J
+               VALUE = MAX( VALUE, ABS( REAL( AP( K ) ) ) )
+   20       CONTINUE
+         ELSE
+            K = 1
+            DO 40 J = 1, N
+               VALUE = MAX( VALUE, ABS( REAL( AP( K ) ) ) )
+               DO 30 I = K + 1, 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 hermitian).
+*
+         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( REAL( 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( REAL( 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 CLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+               K = K + J
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL CLASSQ( 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( REAL( AP( K ) ).NE.ZERO ) THEN
+               ABSA = ABS( REAL( 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
+*
+      CLANHP = VALUE
+      RETURN
+*
+*     End of CLANHP
+*
+      END
diff --git a/SRC/clanhs.f b/SRC/clanhs.f
new file mode 100644
index 00000000..60d9d4d3
--- /dev/null
+++ b/SRC/clanhs.f
@@ -0,0 +1,142 @@
+      REAL             FUNCTION CLANHS( 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 ..
+      REAL               WORK( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANHS  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
+*  ===========
+*
+*  CLANHS returns the value
+*
+*     CLANHS = ( 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 CLANHS as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, CLANHS is
+*          set to zero.
+*
+*  A       (input) COMPLEX 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. 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 CLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANHS = VALUE
+      RETURN
+*
+*     End of CLANHS
+*
+      END
diff --git a/SRC/clanht.f b/SRC/clanht.f
new file mode 100644
index 00000000..7ae6cfda
--- /dev/null
+++ b/SRC/clanht.f
@@ -0,0 +1,125 @@
+      REAL             FUNCTION CLANHT( 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 ..
+      REAL               D( * )
+      COMPLEX            E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANHT  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 tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  CLANHT returns the value
+*
+*     CLANHT = ( 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 CLANHT as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, CLANHT is
+*          set to zero.
+*
+*  D       (input) REAL array, dimension (N)
+*          The diagonal elements of A.
+*
+*  E       (input) COMPLEX array, dimension (N-1)
+*          The (n-1) sub-diagonal or super-diagonal elements of A.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               ANORM, SCALE, SUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ, SLASSQ
+*     ..
+*     .. 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 CLASSQ( N-1, E, 1, SCALE, SUM )
+            SUM = 2*SUM
+         END IF
+         CALL SLASSQ( N, D, 1, SCALE, SUM )
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANHT = ANORM
+      RETURN
+*
+*     End of CLANHT
+*
+      END
diff --git a/SRC/clansb.f b/SRC/clansb.f
new file mode 100644
index 00000000..bb5e096a
--- /dev/null
+++ b/SRC/clansb.f
@@ -0,0 +1,187 @@
+      REAL             FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB,
+     $                 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               WORK( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANSB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n symmetric band matrix A,  with k super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  CLANSB returns the value
+*
+*     CLANSB = ( 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 CLANSB as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          band matrix A is supplied.
+*          = 'U':  Upper triangular part is supplied
+*          = 'L':  Lower triangular part is supplied
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, CLANSB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals or sub-diagonals of the
+*          band matrix A.  K >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first K+1 rows of AB.  The j-th column of A is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = MAX( K+2-J, 1 ), K + 1
+                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               DO 30 I = 1, MIN( N+1-J, K+1 )
+                  VALUE = MAX( VALUE, ABS( AB( 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
+               L = K + 1 - J
+               DO 50 I = MAX( 1, J-K ), J - 1
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( AB( K+1, J ) )
+   60       CONTINUE
+            DO 70 I = 1, N
+               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( AB( 1, J ) )
+               L = 1 - J
+               DO 90 I = J + 1, MIN( N, J+K )
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               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( K.GT.0 ) THEN
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 110 J = 2, N
+                  CALL CLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  110          CONTINUE
+               L = K + 1
+            ELSE
+               DO 120 J = 1, N - 1
+                  CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                         SUM )
+  120          CONTINUE
+               L = 1
+            END IF
+            SUM = 2*SUM
+         ELSE
+            L = 1
+         END IF
+         CALL CLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANSB = VALUE
+      RETURN
+*
+*     End of CLANSB
+*
+      END
diff --git a/SRC/clansp.f b/SRC/clansp.f
new file mode 100644
index 00000000..dccc0bf3
--- /dev/null
+++ b/SRC/clansp.f
@@ -0,0 +1,206 @@
+      REAL             FUNCTION CLANSP( 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 ..
+      REAL               WORK( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANSP  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 symmetric matrix A,  supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  CLANSP returns the value
+*
+*     CLANSP = ( 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 CLANSP 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, CLANSP is
+*          set to zero.
+*
+*  AP      (input) COMPLEX 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, K
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL, 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 CLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+               K = K + J
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL CLASSQ( 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( REAL( AP( K ) ).NE.ZERO ) THEN
+               ABSA = ABS( REAL( 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( AIMAG( AP( K ) ).NE.ZERO ) THEN
+               ABSA = ABS( AIMAG( 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
+*
+      CLANSP = VALUE
+      RETURN
+*
+*     End of CLANSP
+*
+      END
diff --git a/SRC/clansy.f b/SRC/clansy.f
new file mode 100644
index 00000000..d8d5343a
--- /dev/null
+++ b/SRC/clansy.f
@@ -0,0 +1,174 @@
+      REAL             FUNCTION CLANSY( 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 ..
+      REAL               WORK( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANSY  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 symmetric matrix A.
+*
+*  Description
+*  ===========
+*
+*  CLANSY returns the value
+*
+*     CLANSY = ( 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 CLANSY 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, CLANSY is
+*          set to zero.
+*
+*  A       (input) COMPLEX 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. 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 CLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL CLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+  120       CONTINUE
+         END IF
+         SUM = 2*SUM
+         CALL CLASSQ( N, A, LDA+1, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANSY = VALUE
+      RETURN
+*
+*     End of CLANSY
+*
+      END
diff --git a/SRC/clantb.f b/SRC/clantb.f
new file mode 100644
index 00000000..f2f52e75
--- /dev/null
+++ b/SRC/clantb.f
@@ -0,0 +1,285 @@
+      REAL             FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB,
+     $                 LDAB, 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               WORK( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANTB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.
+*
+*  Description
+*  ===========
+*
+*  CLANTB returns the value
+*
+*     CLANTB = ( 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 CLANTB as described
+*          above.
+*
+*  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.  When N = 0, CLANTB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.
+*          K >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first k+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*          Note that when DIAG = 'U', the elements of the array AB
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, L
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = MAX( K+2-J, 1 ), K
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = 2, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   30             CONTINUE
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = MAX( K+2-J, 1 ), K + 1
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = 1, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( 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 ) THEN
+                  SUM = ONE
+                  DO 90 I = MAX( K+2-J, 1 ), K
+                     SUM = SUM + ABS( AB( I, J ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = MAX( K+2-J, 1 ), K + 1
+                     SUM = SUM + ABS( AB( I, J ) )
+  100             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = 2, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = 1, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  130             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  L = K + 1 - J
+                  DO 160 I = MAX( 1, J-K ), J - 1
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  160             CONTINUE
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  L = K + 1 - J
+                  DO 190 I = MAX( 1, J-K ), J
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  L = 1 - J
+                  DO 220 I = J + 1, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  L = 1 - J
+                  DO 250 I = J, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 280 J = 2, N
+                     CALL CLASSQ( MIN( J-1, K ),
+     $                            AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
+     $                            SUM )
+  280             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 290 J = 1, N
+                  CALL CLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 300 J = 1, N - 1
+                     CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                            SUM )
+  300             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 310 J = 1, N
+                  CALL CLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANTB = VALUE
+      RETURN
+*
+*     End of CLANTB
+*
+      END
diff --git a/SRC/clantp.f b/SRC/clantp.f
new file mode 100644
index 00000000..02ac9e70
--- /dev/null
+++ b/SRC/clantp.f
@@ -0,0 +1,286 @@
+      REAL             FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, 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            N
+*     ..
+*     .. Array Arguments ..
+      REAL               WORK( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANTP  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  triangular matrix A, supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  CLANTP returns the value
+*
+*     CLANTP = ( 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 CLANTP as described
+*          above.
+*
+*  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.  When N = 0, CLANTP is
+*          set to zero.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          Note that when DIAG = 'U', the elements of the array AP
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, K
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. 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))).
+*
+         K = 1
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = K, K + J - 2
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10             CONTINUE
+                  K = K + J
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = K + 1, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   30             CONTINUE
+                  K = K + N - J + 1
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = K, K + J - 1
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   50             CONTINUE
+                  K = K + J
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = K, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   70             CONTINUE
+                  K = K + N - J + 1
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         K = 1
+         UDIAG = LSAME( DIAG, 'U' )
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 90 I = K, K + J - 2
+                     SUM = SUM + ABS( AP( I ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = K, K + J - 1
+                     SUM = SUM + ABS( AP( I ) )
+  100             CONTINUE
+               END IF
+               K = K + J
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = K + 1, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = K, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  130             CONTINUE
+               END IF
+               K = K + N - J + 1
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         K = 1
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  DO 160 I = 1, J - 1
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  160             CONTINUE
+                  K = K + 1
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  DO 190 I = 1, J
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  K = K + 1
+                  DO 220 I = J + 1, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  DO 250 I = J, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         VALUE = ZERO
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 280 J = 2, N
+                  CALL CLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  280          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 290 J = 1, N
+                  CALL CLASSQ( J, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 300 J = 1, N - 1
+                  CALL CLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  300          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 310 J = 1, N
+                  CALL CLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANTP = VALUE
+      RETURN
+*
+*     End of CLANTP
+*
+      END
diff --git a/SRC/clantr.f b/SRC/clantr.f
new file mode 100644
index 00000000..f644d628
--- /dev/null
+++ b/SRC/clantr.f
@@ -0,0 +1,277 @@
+      REAL             FUNCTION CLANTR( 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 ..
+      REAL               WORK( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLANTR  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
+*  ===========
+*
+*  CLANTR returns the value
+*
+*     CLANTR = ( 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 CLANTR 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, CLANTR 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, CLANTR is set to zero.
+*
+*  A       (input) COMPLEX 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASSQ
+*     ..
+*     .. 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 CLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
+  290          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 300 J = 1, N
+                  CALL CLASSQ( 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 CLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 320 J = 1, N
+                  CALL CLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
+  320          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      CLANTR = VALUE
+      RETURN
+*
+*     End of CLANTR
+*
+      END
diff --git a/SRC/clapll.f b/SRC/clapll.f
new file mode 100644
index 00000000..2934d62a
--- /dev/null
+++ b/SRC/clapll.f
@@ -0,0 +1,103 @@
+      SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, INCY, N
+      REAL               SSMIN
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given two column vectors X and Y, let
+*
+*                       A = ( X Y ).
+*
+*  The subroutine first computes the QR factorization of A = Q*R,
+*  and then computes the SVD of the 2-by-2 upper triangular matrix R.
+*  The smaller singular value of R is returned in SSMIN, which is used
+*  as the measurement of the linear dependency of the vectors X and Y.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The length of the vectors X and Y.
+*
+*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
+*          On entry, X contains the N-vector X.
+*          On exit, X is overwritten.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive elements of X. INCX > 0.
+*
+*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCY)
+*          On entry, Y contains the N-vector Y.
+*          On exit, Y is overwritten.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive elements of Y. INCY > 0.
+*
+*  SSMIN   (output) REAL
+*          The smallest singular value of the N-by-2 matrix A = ( X Y ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      REAL               SSMAX
+      COMPLEX            A11, A12, A22, C, TAU
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG
+*     ..
+*     .. External Functions ..
+      COMPLEX            CDOTC
+      EXTERNAL           CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CLARFG, SLAS2
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         SSMIN = ZERO
+         RETURN
+      END IF
+*
+*     Compute the QR factorization of the N-by-2 matrix ( X Y )
+*
+      CALL CLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
+      A11 = X( 1 )
+      X( 1 ) = CONE
+*
+      C = -CONJG( TAU )*CDOTC( N, X, INCX, Y, INCY )
+      CALL CAXPY( N, C, X, INCX, Y, INCY )
+*
+      CALL CLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
+*
+      A12 = Y( 1 )
+      A22 = Y( 1+INCY )
+*
+*     Compute the SVD of 2-by-2 Upper triangular matrix.
+*
+      CALL SLAS2( ABS( A11 ), ABS( A12 ), ABS( A22 ), SSMIN, SSMAX )
+*
+      RETURN
+*
+*     End of CLAPLL
+*
+      END
diff --git a/SRC/clapmt.f b/SRC/clapmt.f
new file mode 100644
index 00000000..94d0eb2a
--- /dev/null
+++ b/SRC/clapmt.f
@@ -0,0 +1,136 @@
+      SUBROUTINE CLAPMT( 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( * )
+      COMPLEX            X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAPMT 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) COMPLEX 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, J, IN
+      COMPLEX            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 60 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
+*
+   60    CONTINUE
+*
+      ELSE
+*
+*        Backward permutation
+*
+         DO 110 I = 1, N
+*
+            IF( K( I ).GT.0 )
+     $         GO TO 100
+*
+            K( I ) = -K( I )
+            J = K( I )
+   80       CONTINUE
+            IF( J.EQ.I )
+     $         GO TO 100
+*
+            DO 90 II = 1, M
+               TEMP = X( II, I )
+               X( II, I ) = X( II, J )
+               X( II, J ) = TEMP
+   90       CONTINUE
+*
+            K( J ) = -K( J )
+            J = K( J )
+            GO TO 80
+*
+  100       CONTINUE
+
+  110    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of CLAPMT
+*
+      END
diff --git a/SRC/claqgb.f b/SRC/claqgb.f
new file mode 100644
index 00000000..9eac07ee
--- /dev/null
+++ b/SRC/claqgb.f
@@ -0,0 +1,169 @@
+      SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, 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            KL, KU, LDAB, M, N
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), R( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQGB equilibrates a general M by N band matrix A with KL
+*  subdiagonals and KU superdiagonals using the row and scaling factors
+*  in the vectors R and C.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, the equilibrated matrix, in the same storage format
+*          as A.  See EQUED for the form of the equilibrated matrix.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDA >= KL+KU+1.
+*
+*  R       (input) REAL array, dimension (M)
+*          The row scale factors for A.
+*
+*  C       (input) REAL array, dimension (N)
+*          The column scale factors for A.
+*
+*  ROWCND  (input) REAL
+*          Ratio of the smallest R(i) to the largest R(i).
+*
+*  COLCND  (input) REAL
+*          Ratio of the smallest C(i) to the largest C(i).
+*
+*  AMAX    (input) REAL
+*          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 ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+     $     THEN
+*
+*        No row scaling
+*
+         IF( COLCND.GE.THRESH ) THEN
+*
+*           No column scaling
+*
+            EQUED = 'N'
+         ELSE
+*
+*           Column scaling
+*
+            DO 20 J = 1, N
+               CJ = C( J )
+               DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
+                  AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+            EQUED = 'C'
+         END IF
+      ELSE IF( COLCND.GE.THRESH ) THEN
+*
+*        Row scaling, no column scaling
+*
+         DO 40 J = 1, N
+            DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
+   30       CONTINUE
+   40    CONTINUE
+         EQUED = 'R'
+      ELSE
+*
+*        Row and column scaling
+*
+         DO 60 J = 1, N
+            CJ = C( J )
+            DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
+   50       CONTINUE
+   60    CONTINUE
+         EQUED = 'B'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQGB
+*
+      END
diff --git a/SRC/claqge.f b/SRC/claqge.f
new file mode 100644
index 00000000..0dbca676
--- /dev/null
+++ b/SRC/claqge.f
@@ -0,0 +1,155 @@
+      SUBROUTINE CLAQGE( 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
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), R( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQGE 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) COMPLEX 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) REAL array, dimension (M)
+*          The row scale factors for A.
+*
+*  C       (input) REAL array, dimension (N)
+*          The column scale factors for A.
+*
+*  ROWCND  (input) REAL
+*          Ratio of the smallest R(i) to the largest R(i).
+*
+*  COLCND  (input) REAL
+*          Ratio of the smallest C(i) to the largest C(i).
+*
+*  AMAX    (input) REAL
+*          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 ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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 = SLAMCH( 'Safe minimum' ) / SLAMCH( '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 CLAQGE
+*
+      END
diff --git a/SRC/claqhb.f b/SRC/claqhb.f
new file mode 100644
index 00000000..43b22a86
--- /dev/null
+++ b/SRC/claqhb.f
@@ -0,0 +1,151 @@
+      SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            KD, LDAB, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQHB equilibrates an Hermitian band matrix A using the scaling
+*  factors in the vector S.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  S       (output) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored in band format.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = MAX( 1, J-KD ), J - 1
+                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+   10          CONTINUE
+               AB( KD+1, J ) = CJ*CJ*REAL( AB( KD+1, J ) )
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               AB( 1, J ) = CJ*CJ*REAL( AB( 1, J ) )
+               DO 30 I = J + 1, MIN( N, J+KD )
+                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQHB
+*
+      END
diff --git a/SRC/claqhe.f b/SRC/claqhe.f
new file mode 100644
index 00000000..6309a9b8
--- /dev/null
+++ b/SRC/claqhe.f
@@ -0,0 +1,147 @@
+      SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            LDA, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQHE equilibrates a Hermitian matrix A using the scaling factors
+*  in the vector S.
+*
+*  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 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 EQUED = 'Y', the equilibrated matrix:
+*          diag(S) * A * diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J - 1
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   10          CONTINUE
+               A( J, J ) = CJ*CJ*REAL( A( J, J ) )
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               A( J, J ) = CJ*CJ*REAL( A( J, J ) )
+               DO 30 I = J + 1, N
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQHE
+*
+      END
diff --git a/SRC/claqhp.f b/SRC/claqhp.f
new file mode 100644
index 00000000..4abf1b06
--- /dev/null
+++ b/SRC/claqhp.f
@@ -0,0 +1,146 @@
+      SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQHP equilibrates a Hermitian matrix A using the scaling factors
+*  in the vector S.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
+*          the same storage format as A.
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JC
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            JC = 1
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J - 1
+                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+   10          CONTINUE
+               AP( JC+J-1 ) = CJ*CJ*REAL( AP( JC+J-1 ) )
+               JC = JC + J
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            JC = 1
+            DO 40 J = 1, N
+               CJ = S( J )
+               AP( JC ) = CJ*CJ*REAL( AP( JC ) )
+               DO 30 I = J + 1, N
+                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+   30          CONTINUE
+               JC = JC + N - J + 1
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQHP
+*
+      END
diff --git a/SRC/claqp2.f b/SRC/claqp2.f
new file mode 100644
index 00000000..3e012a71
--- /dev/null
+++ b/SRC/claqp2.f
@@ -0,0 +1,179 @@
+      SUBROUTINE CLAQP2( 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( * )
+      REAL               VN1( * ), VN2( * )
+      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQP2 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 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 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) REAL array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) REAL array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  WORK    (workspace) COMPLEX 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 ..
+      REAL               ZERO, ONE
+      COMPLEX            CONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0,
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
+      REAL               TEMP, TEMP2, TOL3Z
+      COMPLEX            AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CLARFG, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SCNRM2, SLAMCH
+      EXTERNAL           ISAMAX, SCNRM2, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M-OFFSET, N )
+      TOL3Z = SQRT(SLAMCH('Epsilon'))
+*
+*     Compute factorization.
+*
+      DO 20 I = 1, MN
+*
+         OFFPI = OFFSET + I
+*
+*        Determine ith pivot column and swap if necessary.
+*
+         PVT = ( I-1 ) + ISAMAX( N-I+1, VN1( I ), 1 )
+*
+         IF( PVT.NE.I ) THEN
+            CALL CSWAP( 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 CLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+     $                   TAU( I ) )
+         ELSE
+            CALL CLARFG( 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 CLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+     $                  CONJG( 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 ) = SCNRM2( 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 CLAQP2
+*
+      END
diff --git a/SRC/claqps.f b/SRC/claqps.f
new file mode 100644
index 00000000..5d0e6c04
--- /dev/null
+++ b/SRC/claqps.f
@@ -0,0 +1,271 @@
+      SUBROUTINE CLAQPS( 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( * )
+      REAL               VN1( * ), VN2( * )
+      COMPLEX            A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQPS 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 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 array, dimension (KB)
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) REAL array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) REAL array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  AUXV    (input/output) COMPLEX array, dimension (NB)
+*          Auxiliar vector.
+*
+*  F       (input/output) COMPLEX 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 ..
+      REAL               ZERO, ONE
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0,
+     $                   CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
+      REAL               TEMP, TEMP2, TOL3Z
+      COMPLEX            AKK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CGEMV, CLARFG, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, MIN, NINT, REAL, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SCNRM2, SLAMCH
+      EXTERNAL           ISAMAX, SCNRM2, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      LASTRK = MIN( M, N+OFFSET )
+      LSTICC = 0
+      K = 0
+      TOL3Z = SQRT(SLAMCH('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 ) + ISAMAX( N-K+1, VN1( K ), 1 )
+         IF( PVT.NE.K ) THEN
+            CALL CSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
+            CALL CSWAP( 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 ) = CONJG( F( K, J ) )
+   20       CONTINUE
+            CALL CGEMV( '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 ) = CONJG( F( K, J ) )
+   30       CONTINUE
+         END IF
+*
+*        Generate elementary reflector H(k).
+*
+         IF( RK.LT.M ) THEN
+            CALL CLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+         ELSE
+            CALL CLARFG( 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 CGEMV( '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 CGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ),
+     $                  A( RK, 1 ), LDA, A( RK, K ), 1, CZERO,
+     $                  AUXV( 1 ), 1 )
+*
+            CALL CGEMV( '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 CGEMM( '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 ) = REAL( 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 CGEMM( '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 ) = SCNRM2( 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 CLAQPS
+*
+      END
diff --git a/SRC/claqr0.f b/SRC/claqr0.f
new file mode 100644
index 00000000..e93f5749
--- /dev/null
+++ b/SRC/claqr0.f
@@ -0,0 +1,601 @@
+      SUBROUTINE CLAQR0( 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            H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     CLAQR0 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 CGEBAL, and then passed to CGEHRD when the
+*           matrix output by CGEBAL 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 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 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 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 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 CLAQR0 does a workspace query.
+*           In this case, CLAQR0 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, CLAQR0 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
+*     .    CLAHQR 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 )
+      REAL               WILK1
+      PARAMETER          ( WILK1 = 0.75e0 )
+      COMPLEX            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
+      REAL               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            ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACPY, CLAHQR, CLAQR3, CLAQR4, CLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, INT, MAX, MIN, MOD, REAL,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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 CLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL CLAHQR( 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, 'CLAQR0', 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, 'CLAQR0', 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 CLAQR3 ====
+*
+         CALL CLAQR3( 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(CLAQR5, CLAQR3) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = CMPLX( LWKOPT, 0 )
+            RETURN
+         END IF
+*
+*        ==== CLAHQR/CLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'CLAQR0', 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, 'CLAQR0', 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 CLAQR3( 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 CLAQR3
+*              .    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
+*              .    CLAQR3 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 CLAQR4 or
+*                 .    CLAHQR 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 CLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     IF( NS.GT.NMIN ) THEN
+                        CALL CLAQR4( .false., .false., NS, 1, NS,
+     $                               H( KT, 1 ), LDH, W( KS ), 1, 1,
+     $                               ZDUM, 1, WORK, LWORK, INF )
+                     ELSE
+                        CALL CLAHQR( .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 CLAQR5( 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 ) = CMPLX( LWKOPT, 0 )
+*
+*     ==== End of CLAQR0 ====
+*
+      END
diff --git a/SRC/claqr1.f b/SRC/claqr1.f
new file mode 100644
index 00000000..c491268f
--- /dev/null
+++ b/SRC/claqr1.f
@@ -0,0 +1,97 @@
+      SUBROUTINE CLAQR1( 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            S1, S2
+      INTEGER            LDH, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            H( LDH, * ), V( * )
+*     ..
+*
+*       Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 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 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
+*       S2     S1 and S2 are the shifts defining K in (*) above.
+*
+*       V      (output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ) )
+      REAL               RZERO
+      PARAMETER          ( RZERO = 0.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            CDUM
+      REAL               H21S, H31S, S
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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/claqr2.f b/SRC/claqr2.f
new file mode 100644
index 00000000..2bdea99a
--- /dev/null
+++ b/SRC/claqr2.f
@@ -0,0 +1,438 @@
+      SUBROUTINE CLAQR2( 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            H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
+*     ..
+*
+*     This subroutine is identical to CLAQR3 except that it avoids
+*     recursion by calling CLAHQR instead of CLAQR4.
+*
+*
+*     ******************************************************************
+*     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 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 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 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 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 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 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 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; CLAQR2
+*          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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               RZERO, RONE
+      PARAMETER          ( RZERO = 0.0e0, RONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            BETA, CDUM, S, TAU
+      REAL               FOO, SAFMAX, SAFMIN, SMLNUM, ULP
+      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
+     $                   KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLARF,
+     $                   CLARFG, CLASET, CTREXC, CUNGHR, SLABAD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to CGEHRD ====
+*
+         CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to CUNGHR ====
+*
+         CALL CUNGHR( 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 ) = CMPLX( 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      CALL CLAHQR( .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.   (CTREXC can not fail in this case.) ====
+*
+            IFST = NS
+            CALL CTREXC( '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 CTREXC( '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 CCOPY( NS, V, LDV, WORK, 1 )
+            DO 50 I = 1, NS
+               WORK( I ) = CONJG( WORK( I ) )
+   50       CONTINUE
+            BETA = WORK( 1 )
+            CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL CGEHRD( 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*CONJG( V( 1, 1 ) )
+         CALL CLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL CCOPY( 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  CUNGHR 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 CUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL CGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL CLACPY( '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 CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL CLACPY( '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 CGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL CLACPY( '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 CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL CLACPY( '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 ) = CMPLX( LWKOPT, 0 )
+*
+*     ==== End of CLAQR2 ====
+*
+      END
diff --git a/SRC/claqr3.f b/SRC/claqr3.f
new file mode 100644
index 00000000..7fbcdb4d
--- /dev/null
+++ b/SRC/claqr3.f
@@ -0,0 +1,448 @@
+      SUBROUTINE CLAQR3( 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            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 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 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 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 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 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 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 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; CLAQR3
+*          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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               RZERO, RONE
+      PARAMETER          ( RZERO = 0.0e0, RONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            BETA, CDUM, S, TAU
+      REAL               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 ..
+      REAL               SLAMCH
+      INTEGER            ILAENV
+      EXTERNAL           SLAMCH, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4,
+     $                   CLARF, CLARFG, CLASET, CTREXC, CUNGHR, SLABAD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to CGEHRD ====
+*
+         CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to CUNGHR ====
+*
+         CALL CUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK2 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to CLAQR4 ====
+*
+         CALL CLAQR4( .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 ) = CMPLX( 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      NMIN = ILAENV( 12, 'CLAQR3', 'SV', JW, 1, JW, LWORK )
+      IF( JW.GT.NMIN ) THEN
+         CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+     $                JW, V, LDV, WORK, LWORK, INFQR )
+      ELSE
+         CALL CLAHQR( .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.   (CTREXC can not fail in this case.) ====
+*
+            IFST = NS
+            CALL CTREXC( '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 CTREXC( '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 CCOPY( NS, V, LDV, WORK, 1 )
+            DO 50 I = 1, NS
+               WORK( I ) = CONJG( WORK( I ) )
+   50       CONTINUE
+            BETA = WORK( 1 )
+            CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL CGEHRD( 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*CONJG( V( 1, 1 ) )
+         CALL CLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL CCOPY( 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  CUNGHR 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 CUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL CGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL CLACPY( '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 CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL CLACPY( '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 CGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL CLACPY( '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 CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL CLACPY( '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 ) = CMPLX( LWKOPT, 0 )
+*
+*     ==== End of CLAQR3 ====
+*
+      END
diff --git a/SRC/claqr4.f b/SRC/claqr4.f
new file mode 100644
index 00000000..7e4fe4d7
--- /dev/null
+++ b/SRC/claqr4.f
@@ -0,0 +1,602 @@
+      SUBROUTINE CLAQR4( 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            H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*     This subroutine implements one level of recursion for CLAQR0.
+*     It is a complete implementation of the small bulge multi-shift
+*     QR algorithm.  It may be called by CLAQR0 and, for large enough
+*     deflation window size, it may be called by CLAQR3.  This
+*     subroutine is identical to CLAQR0 except that it calls CLAQR2
+*     instead of CLAQR3.
+*
+*     Purpose
+*     =======
+*
+*     CLAQR4 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 CGEBAL, and then passed to CGEHRD when the
+*           matrix output by CGEBAL 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 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 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 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 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 CLAQR4 does a workspace query.
+*           In this case, CLAQR4 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, CLAQR4 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
+*     .    CLAHQR 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 )
+      REAL               WILK1
+      PARAMETER          ( WILK1 = 0.75e0 )
+      COMPLEX            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
+      REAL               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            ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACPY, CLAHQR, CLAQR2, CLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, INT, MAX, MIN, MOD, REAL,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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 CLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL CLAHQR( 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, 'CLAQR4', 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, 'CLAQR4', 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 CLAQR2 ====
+*
+         CALL CLAQR2( 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(CLAQR5, CLAQR2) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = CMPLX( LWKOPT, 0 )
+            RETURN
+         END IF
+*
+*        ==== CLAHQR/CLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'CLAQR4', 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, 'CLAQR4', 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 CLAQR2( 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 CLAQR2
+*              .    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
+*              .    CLAQR2 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 CLAHQR
+*                 .    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 CLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     CALL CLAHQR( .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 CLAQR5( 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 ) = CMPLX( LWKOPT, 0 )
+*
+*     ==== End of CLAQR4 ====
+*
+      END
diff --git a/SRC/claqr5.f b/SRC/claqr5.f
new file mode 100644
index 00000000..0fb2bbd3
--- /dev/null
+++ b/SRC/claqr5.f
@@ -0,0 +1,809 @@
+      SUBROUTINE CLAQR5( 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            H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
+     $                   WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
+*     ..
+*
+*     This auxiliary subroutine called by CLAQR0 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: CLAQR5 does not accumulate reflections and does not
+*             use matrix-matrix multiply to update far-from-diagonal
+*             matrix entries.
+*        = 1: CLAQR5 accumulates reflections and uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries.
+*        = 2: CLAQR5 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 array of size (NSHFTS)
+*             S contains the shifts of origin that define the multi-
+*             shift QR sweep.
+*
+*      H      (input/output) COMPLEX 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 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 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 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 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 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0e0, 0.0e0 ),
+     $                   ONE = ( 1.0e0, 0.0e0 ) )
+      REAL               RZERO, RONE
+      PARAMETER          ( RZERO = 0.0e0, RONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX            ALPHA, BETA, CDUM, REFSUM
+      REAL               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 ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+*
+      INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, MOD, REAL
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            VT( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CLACPY, CLAQR1, CLARFG, CLASET, CTRMM,
+     $                   SLABAD
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 CLASET( '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 CLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ),
+     $                         S( 2*M ), V( 1, M ) )
+                  ALPHA = V( 1, M )
+                  CALL CLARFG( 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 CLARFG( 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 CLAQR1( 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 CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
+                        REFSUM = H( K+1, K ) +
+     $                           H( K+2, K )*CONJG( VT( 2 ) ) +
+     $                           H( K+3, K )*CONJG( VT( 3 ) )
+                        H( K+1, K ) = H( K+1, K ) -
+     $                                CONJG( 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 CLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ),
+     $                         S( 2*M22 ), V( 1, M22 ) )
+                  BETA = V( 1, M22 )
+                  CALL CLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M22 ) = H( K+2, K )
+                  CALL CLARFG( 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 = CONJG( V( 1, M ) )*
+     $                     ( H( K+1, J )+CONJG( V( 2, M ) )*H( K+2, J )+
+     $                     CONJG( 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 = CONJG( V( 1, M22 ) )*
+     $                     ( H( K+1, J )+CONJG( 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*CONJG( V( 2, M ) )
+                     H( J, K+3 ) = H( J, K+3 ) -
+     $                             REFSUM*CONJG( 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*CONJG( V( 2, M ) )
+                        U( J, KMS+3 ) = U( J, KMS+3 ) -
+     $                                  REFSUM*CONJG( 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*CONJG( V( 2, M ) )
+                        Z( J, K+3 ) = Z( J, K+3 ) -
+     $                                REFSUM*CONJG( 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*CONJG( 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*CONJG( 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*CONJG( 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*CONJG( V( 2, M ) )
+               H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*CONJG( 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 CGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+     $                        LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+     $                        LDWH )
+                  CALL CLACPY( '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 CGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                        H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+     $                        LDU, ZERO, WV, LDWV )
+                  CALL CLACPY( '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 CGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                           Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+     $                           LDU, ZERO, WV, LDWV )
+                     CALL CLACPY( '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 CLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+     $                         LDH, WH( KZS+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL CLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+                  CALL CTRMM( '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 CGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+     $                        H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+*                 ==== Copy top of H bottom of WH ====
+*
+                  CALL CLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+     $                         WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL CTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+     $                        U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL CGEMM( '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 CLACPY( '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 CLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+     $                         LDH, WV( 1, 1+KZS ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL CLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+                  CALL CTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                        LDWV )
+*
+*                 ==== Multiply by U11 ====
+*
+                  CALL CGEMM( '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 CLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+     $                         WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL CTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                        U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL CGEMM( '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 CLACPY( '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 CLACPY( 'ALL', JLEN, KNZ,
+     $                            Z( JROW, INCOL+1+J2 ), LDZ,
+     $                            WV( 1, 1+KZS ), LDWV )
+*
+*                    ==== Multiply by U12 ====
+*
+                     CALL CLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+     $                            LDWV )
+                     CALL CTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                           U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U11 ====
+*
+                     CALL CGEMM( '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 CLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+     $                            LDZ, WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Multiply by U21 ====
+*
+                     CALL CTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                           U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U22 ====
+*
+                     CALL CGEMM( '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 CLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+     $                            Z( JROW, INCOL+1 ), LDZ )
+  200             CONTINUE
+               END IF
+            END IF
+         END IF
+  210 CONTINUE
+*
+*     ==== End of CLAQR5 ====
+*
+      END
diff --git a/SRC/claqsb.f b/SRC/claqsb.f
new file mode 100644
index 00000000..0ac7e6a4
--- /dev/null
+++ b/SRC/claqsb.f
@@ -0,0 +1,149 @@
+      SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            KD, LDAB, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQSB equilibrates a symmetric band matrix A using the scaling
+*  factors in the vector S.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored in band format.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = MAX( 1, J-KD ), J
+                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, MIN( N, J+KD )
+                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQSB
+*
+      END
diff --git a/SRC/claqsp.f b/SRC/claqsp.f
new file mode 100644
index 00000000..98d0682c
--- /dev/null
+++ b/SRC/claqsp.f
@@ -0,0 +1,141 @@
+      SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQSP equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
+*          the same storage format as A.
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JC
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            JC = 1
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+   10          CONTINUE
+               JC = JC + J
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            JC = 1
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+   30          CONTINUE
+               JC = JC + N - J + 1
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQSP
+*
+      END
diff --git a/SRC/claqsy.f b/SRC/claqsy.f
new file mode 100644
index 00000000..bc8146fe
--- /dev/null
+++ b/SRC/claqsy.f
@@ -0,0 +1,142 @@
+      SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            LDA, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAQSY equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if EQUED = 'Y', the equilibrated matrix:
+*          diag(S) * A * diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of CLAQSY
+*
+      END
diff --git a/SRC/clar1v.f b/SRC/clar1v.f
new file mode 100644
index 00000000..69f37db6
--- /dev/null
+++ b/SRC/clar1v.f
@@ -0,0 +1,371 @@
+      SUBROUTINE CLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
+     $           PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+     $           R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTNC
+      INTEGER   B1, BN, N, NEGCNT, R
+      REAL               GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+     $                   RQCORR, ZTZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * )
+      REAL               D( * ), L( * ), LD( * ), LLD( * ),
+     $                  WORK( * )
+      COMPLEX          Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAR1V computes the (scaled) r-th column of the inverse of
+*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+*  L D L^T - sigma I. When sigma is close to an eigenvalue, the
+*  computed vector is an accurate eigenvector. Usually, r corresponds
+*  to the index where the eigenvector is largest in magnitude.
+*  The following steps accomplish this computation :
+*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
+*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+*  (c) Computation of the diagonal elements of the inverse of
+*      L D L^T - sigma I by combining the above transforms, and choosing
+*      r as the index where the diagonal of the inverse is (one of the)
+*      largest in magnitude.
+*  (d) Computation of the (scaled) r-th column of the inverse using the
+*      twisted factorization obtained by combining the top part of the
+*      the stationary and the bottom part of the progressive transform.
+*
+*  Arguments
+*  =========
+*
+*  N        (input) INTEGER
+*           The order of the matrix L D L^T.
+*
+*  B1       (input) INTEGER
+*           First index of the submatrix of L D L^T.
+*
+*  BN       (input) INTEGER
+*           Last index of the submatrix of L D L^T.
+*
+*  LAMBDA    (input) REAL            
+*           The shift. In order to compute an accurate eigenvector,
+*           LAMBDA should be a good approximation to an eigenvalue
+*           of L D L^T.
+*
+*  L        (input) REAL             array, dimension (N-1)
+*           The (n-1) subdiagonal elements of the unit bidiagonal matrix
+*           L, in elements 1 to N-1.
+*
+*  D        (input) REAL             array, dimension (N)
+*           The n diagonal elements of the diagonal matrix D.
+*
+*  LD       (input) REAL             array, dimension (N-1)
+*           The n-1 elements L(i)*D(i).
+*
+*  LLD      (input) REAL             array, dimension (N-1)
+*           The n-1 elements L(i)*L(i)*D(i).
+*
+*  PIVMIN   (input) REAL            
+*           The minimum pivot in the Sturm sequence.
+*
+*  GAPTOL   (input) REAL            
+*           Tolerance that indicates when eigenvector entries are negligible
+*           w.r.t. their contribution to the residual.
+*
+*  Z        (input/output) COMPLEX          array, dimension (N)
+*           On input, all entries of Z must be set to 0.
+*           On output, Z contains the (scaled) r-th column of the
+*           inverse. The scaling is such that Z(R) equals 1.
+*
+*  WANTNC   (input) LOGICAL
+*           Specifies whether NEGCNT has to be computed.
+*
+*  NEGCNT   (output) INTEGER
+*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+*  ZTZ      (output) REAL            
+*           The square of the 2-norm of Z.
+*
+*  MINGMA   (output) REAL            
+*           The reciprocal of the largest (in magnitude) diagonal
+*           element of the inverse of L D L^T - sigma I.
+*
+*  R        (input/output) INTEGER
+*           The twist index for the twisted factorization used to
+*           compute Z.
+*           On input, 0 <= R <= N. If R is input as 0, R is set to
+*           the index where (L D L^T - sigma I)^{-1} is largest
+*           in magnitude. If 1 <= R <= N, R is unchanged.
+*           On output, R contains the twist index used to compute Z.
+*           Ideally, R designates the position of the maximum entry in the
+*           eigenvector.
+*
+*  ISUPPZ   (output) INTEGER array, dimension (2)
+*           The support of the vector in Z, i.e., the vector Z is
+*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+*  NRMINV   (output) REAL            
+*           NRMINV = 1/SQRT( ZTZ )
+*
+*  RESID    (output) REAL            
+*           The residual of the FP vector.
+*           RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+*  RQCORR   (output) REAL            
+*           The Rayleigh Quotient correction to LAMBDA.
+*           RQCORR = MINGMA*TMP
+*
+*  WORK     (workspace) REAL             array, dimension (4*N)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E0, 0.0E0 ) )
+
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SAWNAN1, SAWNAN2
+      INTEGER            I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
+     $                   R2
+      REAL               DMINUS, DPLUS, EPS, S, TMP
+*     ..
+*     .. External Functions ..
+      LOGICAL SISNAN
+      REAL               SLAMCH
+      EXTERNAL           SISNAN, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = SLAMCH( 'Precision' )
+
+
+      IF( R.EQ.0 ) THEN
+         R1 = B1
+         R2 = BN
+      ELSE
+         R1 = R
+         R2 = R
+      END IF
+
+*     Storage for LPLUS
+      INDLPL = 0
+*     Storage for UMINUS
+      INDUMN = N
+      INDS = 2*N + 1
+      INDP = 3*N + 1
+
+      IF( B1.EQ.1 ) THEN
+         WORK( INDS ) = ZERO
+      ELSE
+         WORK( INDS+B1-1 ) = LLD( B1-1 )
+      END IF
+
+*
+*     Compute the stationary transform (using the differential form)
+*     until the index R2.
+*
+      SAWNAN1 = .FALSE.
+      NEG1 = 0
+      S = WORK( INDS+B1-1 ) - LAMBDA
+      DO 50 I = B1, R1 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 50   CONTINUE
+      SAWNAN1 = SISNAN( S )
+      IF( SAWNAN1 ) GOTO 60
+      DO 51 I = R1, R2 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 51   CONTINUE
+      SAWNAN1 = SISNAN( S )
+*
+ 60   CONTINUE
+      IF( SAWNAN1 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG1 = 0
+         S = WORK( INDS+B1-1 ) - LAMBDA
+         DO 70 I = B1, R1 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 70      CONTINUE
+         DO 71 I = R1, R2 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 71      CONTINUE
+      END IF
+*
+*     Compute the progressive transform (using the differential form)
+*     until the index R1
+*
+      SAWNAN2 = .FALSE.
+      NEG2 = 0
+      WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
+      DO 80 I = BN - 1, R1, -1
+         DMINUS = LLD( I ) + WORK( INDP+I )
+         TMP = D( I ) / DMINUS
+         IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+         WORK( INDUMN+I ) = L( I )*TMP
+         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ 80   CONTINUE
+      TMP = WORK( INDP+R1-1 )
+      SAWNAN2 = SISNAN( TMP )
+
+      IF( SAWNAN2 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG2 = 0
+         DO 100 I = BN-1, R1, -1
+            DMINUS = LLD( I ) + WORK( INDP+I )
+            IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
+            TMP = D( I ) / DMINUS
+            IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+            WORK( INDUMN+I ) = L( I )*TMP
+            WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+            IF( TMP.EQ.ZERO )
+     $          WORK( INDP+I-1 ) = D( I ) - LAMBDA
+ 100     CONTINUE
+      END IF
+*
+*     Find the index (from R1 to R2) of the largest (in magnitude)
+*     diagonal element of the inverse
+*
+      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
+      IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
+      IF( WANTNC ) THEN
+         NEGCNT = NEG1 + NEG2
+      ELSE
+         NEGCNT = -1
+      ENDIF
+      IF( ABS(MINGMA).EQ.ZERO )
+     $   MINGMA = EPS*WORK( INDS+R1-1 )
+      R = R1
+      DO 110 I = R1, R2 - 1
+         TMP = WORK( INDS+I ) + WORK( INDP+I )
+         IF( TMP.EQ.ZERO )
+     $      TMP = EPS*WORK( INDS+I )
+         IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
+            MINGMA = TMP
+            R = I + 1
+         END IF
+ 110  CONTINUE
+*
+*     Compute the FP vector: solve N^T v = e_r
+*
+      ISUPPZ( 1 ) = B1
+      ISUPPZ( 2 ) = BN
+      Z( R ) = CONE
+      ZTZ = ONE
+*
+*     Compute the FP vector upwards from R
+*
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 210 I = R-1, B1, -1
+            Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GOTO 220
+            ENDIF
+            ZTZ = ZTZ + REAL( Z( I )*Z( I ) )
+ 210     CONTINUE
+ 220     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 230 I = R - 1, B1, -1
+            IF( Z( I+1 ).EQ.ZERO ) THEN
+               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
+            ELSE
+               Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GO TO 240
+            END IF
+            ZTZ = ZTZ + REAL( Z( I )*Z( I ) )
+ 230     CONTINUE
+ 240     CONTINUE
+      ENDIF
+
+*     Compute the FP vector downwards from R in blocks of size BLKSIZ
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 250 I = R, BN-1
+            Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $         THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 260
+            END IF
+            ZTZ = ZTZ + REAL( Z( I+1 )*Z( I+1 ) )
+ 250     CONTINUE
+ 260     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 270 I = R, BN - 1
+            IF( Z( I ).EQ.ZERO ) THEN
+               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
+            ELSE
+               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 280
+            END IF
+            ZTZ = ZTZ + REAL( Z( I+1 )*Z( I+1 ) )
+ 270     CONTINUE
+ 280     CONTINUE
+      END IF
+*
+*     Compute quantities for convergence test
+*
+      TMP = ONE / ZTZ
+      NRMINV = SQRT( TMP )
+      RESID = ABS( MINGMA )*NRMINV
+      RQCORR = MINGMA*TMP
+*
+*
+      RETURN
+*
+*     End of CLAR1V
+*
+      END
diff --git a/SRC/clar2v.f b/SRC/clar2v.f
new file mode 100644
index 00000000..a1e9bbd1
--- /dev/null
+++ b/SRC/clar2v.f
@@ -0,0 +1,97 @@
+      SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, N
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * )
+      COMPLEX            S( * ), X( * ), Y( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAR2V applies a vector of complex plane rotations with real cosines
+*  from both sides to a sequence of 2-by-2 complex Hermitian matrices,
+*  defined by the elements of the vectors x, y and z. For i = 1,2,...,n
+*
+*     (       x(i)  z(i) ) :=
+*     ( conjg(z(i)) y(i) )
+*
+*       (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )
+*       ( -s(i)       c(i)  ) ( conjg(z(i)) y(i) ) ( s(i)        c(i)  )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
+*          The vector x; the elements of x are assumed to be real.
+*
+*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
+*          The vector y; the elements of y are assumed to be real.
+*
+*  Z       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
+*          The vector z.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X, Y and Z. INCX > 0.
+*
+*  C       (input) REAL array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) COMPLEX array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX
+      REAL               CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,
+     $                   ZIR
+      COMPLEX            SI, T2, T3, T4, ZI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, CONJG, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = REAL( X( IX ) )
+         YI = REAL( Y( IX ) )
+         ZI = Z( IX )
+         ZIR = REAL( ZI )
+         ZII = AIMAG( ZI )
+         CI = C( IC )
+         SI = S( IC )
+         SIR = REAL( SI )
+         SII = AIMAG( SI )
+         T1R = SIR*ZIR - SII*ZII
+         T1I = SIR*ZII + SII*ZIR
+         T2 = CI*ZI
+         T3 = T2 - CONJG( SI )*XI
+         T4 = CONJG( T2 ) + SI*YI
+         T5 = CI*XI + T1R
+         T6 = CI*YI - T1R
+         X( IX ) = CI*T5 + ( SIR*REAL( T4 )+SII*AIMAG( T4 ) )
+         Y( IX ) = CI*T6 - ( SIR*REAL( T3 )-SII*AIMAG( T3 ) )
+         Z( IX ) = CI*T3 + CONJG( SI )*CMPLX( T6, T1I )
+         IX = IX + INCX
+         IC = IC + INCC
+   10 CONTINUE
+      RETURN
+*
+*     End of CLAR2V
+*
+      END
diff --git a/SRC/clarcm.f b/SRC/clarcm.f
new file mode 100644
index 00000000..f01d683f
--- /dev/null
+++ b/SRC/clarcm.f
@@ -0,0 +1,110 @@
+      SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDB, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), RWORK( * )
+      COMPLEX            B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARCM performs a very simple matrix-matrix multiplication:
+*           C := A * B,
+*  where A is M by M and real; B is M by N and complex;
+*  C is M by N and complex.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A and of the matrix C.
+*          M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns and rows of the matrix B and
+*          the number of columns of the matrix C.
+*          N >= 0.
+*
+*  A       (input) REAL array, dimension (LDA, M)
+*          A contains the M by M matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >=max(1,M).
+*
+*  B       (input) REAL array, dimension (LDB, N)
+*          B contains the M by N matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >=max(1,M).
+*
+*  C       (input) COMPLEX array, dimension (LDC, N)
+*          C contains the M by N matrix C.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >=max(1,M).
+*
+*  RWORK   (workspace) REAL array, dimension (2*M*N)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, REAL
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+     $   RETURN
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, M
+            RWORK( ( J-1 )*M+I ) = REAL( B( I, J ) )
+   10    CONTINUE
+   20 CONTINUE
+*
+      L = M*N + 1
+      CALL SGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
+     $            RWORK( L ), M )
+      DO 40 J = 1, N
+         DO 30 I = 1, M
+            C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
+   30    CONTINUE
+   40 CONTINUE
+*
+      DO 60 J = 1, N
+         DO 50 I = 1, M
+            RWORK( ( J-1 )*M+I ) = AIMAG( B( I, J ) )
+   50    CONTINUE
+   60 CONTINUE
+      CALL SGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
+     $            RWORK( L ), M )
+      DO 80 J = 1, N
+         DO 70 I = 1, M
+            C( I, J ) = CMPLX( REAL( C( I, J ) ),
+     $                  RWORK( L+( J-1 )*M+I-1 ) )
+   70    CONTINUE
+   80 CONTINUE
+*
+      RETURN
+*
+*     End of CLARCM
+*
+      END
diff --git a/SRC/clarf.f b/SRC/clarf.f
new file mode 100644
index 00000000..e98d8a8c
--- /dev/null
+++ b/SRC/clarf.f
@@ -0,0 +1,157 @@
+      SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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            TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARF 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 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
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX 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 array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            APPLYLEFT
+      INTEGER            I, LASTV, LASTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CGERC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILACLR, ILACLC
+      EXTERNAL           LSAME, ILACLR, ILACLC
+*     ..
+*     .. Executable Statements ..
+*
+      APPLYLEFT = LSAME( SIDE, 'L' )
+      LASTV = 0
+      LASTC = 0
+      IF( TAU.NE.ZERO ) THEN
+!     Set up variables for scanning V.  LASTV begins pointing to the end
+!     of V.
+         IF( APPLYLEFT ) THEN
+            LASTV = M
+         ELSE
+            LASTV = N
+         END IF
+         IF( INCV.GT.0 ) THEN
+            I = 1 + (LASTV-1) * INCV
+         ELSE
+            I = 1
+         END IF
+!     Look for the last non-zero row in V.
+         DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
+            LASTV = LASTV - 1
+            I = I - INCV
+         END DO
+         IF( APPLYLEFT ) THEN
+!     Scan for the last non-zero column in C(1:lastv,:).
+            LASTC = ILACLC(LASTV, N, C, LDC)
+         ELSE
+!     Scan for the last non-zero row in C(:,1:lastv).
+            LASTC = ILACLR(M, LASTV, C, LDC)
+         END IF
+      END IF
+!     Note that lastc.eq.0 renders the BLAS operations null; no special
+!     case is needed at this level.
+      IF( APPLYLEFT ) THEN
+*
+*        Form  H * C
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
+*
+            CALL CGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
+     $           C, LDC, V, INCV, ZERO, WORK, 1 )
+*
+*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
+*
+            CALL CGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+            CALL CGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
+     $           V, INCV, ZERO, WORK, 1 )
+*
+*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
+*
+            CALL CGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of CLARF
+*
+      END
diff --git a/SRC/clarfb.f b/SRC/clarfb.f
new file mode 100644
index 00000000..3418b460
--- /dev/null
+++ b/SRC/clarfb.f
@@ -0,0 +1,649 @@
+      SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+      IMPLICIT NONE
+*
+*  -- 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            C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARFB 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 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 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 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, J, LASTV, LASTC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILACLR, ILACLC
+      EXTERNAL           LSAME, ILACLR, ILACLC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMM, CLACGV, CTRMM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. 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 )
+*
+               LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
+               LASTC = ILACLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL CGEMM( 'Conjugate transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
+     $                 V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV,
+     $                 WORK, LDWORK, ONE, C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, LASTC
+                     C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
+   20             CONTINUE
+   30          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+               LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
+               LASTC = ILACLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL CGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, LASTV-K, K,
+     $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
+     $                 ONE, C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
+               LASTC = ILACLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+                  CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL CGEMM( 'Conjugate transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
+     $                               CONJG( WORK( I, J ) )
+   80             CONTINUE
+   90          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+               LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
+               LASTC = ILACLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
+     $                 WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL CGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-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 )
+*
+               LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
+               LASTC = ILACLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL CGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTC, K, LASTV-K,
+     $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL CGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTV-K, LASTC, K,
+     $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
+     $                 ONE, C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, LASTC
+                     C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
+  140             CONTINUE
+  150          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+               LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
+               LASTC = ILACLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
+     $                 V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL CGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-K, K,
+     $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
+     $                 ONE, C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
+               LASTC = ILACLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+                  CALL CLACGV( LASTC, WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL CGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTC, K, LASTV-K,
+     $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL CGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTV-K, LASTC, K,
+     $                 -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
+     $                               CONJG( WORK( I, J ) )
+  200             CONTINUE
+  210          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+               LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
+               LASTC = ILACLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
+     $                 WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
+     $                 WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL CGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-K+J )
+     $                    - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CLARFB
+*
+      END
diff --git a/SRC/clarfg.f b/SRC/clarfg.f
new file mode 100644
index 00000000..8867f54b
--- /dev/null
+++ b/SRC/clarfg.f
@@ -0,0 +1,140 @@
+      SUBROUTINE CLARFG( 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            ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARFG 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
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) COMPLEX 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
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      REAL               ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      REAL               SCNRM2, SLAMCH, SLAPY3
+      COMPLEX            CLADIV
+      EXTERNAL           SCNRM2, SLAMCH, SLAPY3, CLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, REAL, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSCAL, CSSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = SCNRM2( N-1, X, INCX )
+      ALPHR = REAL( ALPHA )
+      ALPHI = AIMAG( ALPHA )
+*
+      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
+         RSAFMN = ONE / SAFMIN
+*
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL CSSCAL( 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 = SCNRM2( N-1, X, INCX )
+            ALPHA = CMPLX( ALPHR, ALPHI )
+            BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         END IF
+         TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+         ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA )
+         CALL CSCAL( N-1, ALPHA, X, INCX )
+*
+*        If ALPHA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of CLARFG
+*
+      END
diff --git a/SRC/clarfp.f b/SRC/clarfp.f
new file mode 100644
index 00000000..51c2ba4f
--- /dev/null
+++ b/SRC/clarfp.f
@@ -0,0 +1,172 @@
+      SUBROUTINE CLARFP( 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            ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARFP 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, beta is real and non-negative, 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
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) COMPLEX 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
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0E+0, ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      REAL               ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      REAL               SCNRM2, SLAMCH, SLAPY3, SLAPY2
+      COMPLEX            CLADIV
+      EXTERNAL           SCNRM2, SLAMCH, SLAPY3, SLAPY2, CLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, REAL, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSCAL, CSSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = SCNRM2( N-1, X, INCX )
+      ALPHR = REAL( ALPHA )
+      ALPHI = AIMAG( ALPHA )
+*
+      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
+*
+*        H  =  [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0.
+*
+         IF( ALPHI.EQ.ZERO ) THEN
+            IF( ALPHR.GE.ZERO ) THEN
+!              When TAU.eq.ZERO, the vector is special-cased to be
+!              all zeros in the application routines.  We do not need
+!              to clear it.
+               TAU = ZERO
+            ELSE
+!              However, the application routines rely on explicit
+!              zero checks when TAU.ne.ZERO, and we must clear X.
+               TAU = TWO
+               DO J = 1, N-1
+                  X( 1 + (J-1)*INCX ) = 0
+               END DO
+               ALPHA = -ALPHA
+            END IF
+         ELSE
+!           Only "reflecting" the diagonal entry to be real and non-negative.
+            XNORM = SLAPY2( ALPHR, ALPHI )
+            TAU = CMPLX( ONE - ALPHR / XNORM, -ALPHI / XNORM )
+            DO J = 1, N-1
+               X( 1 + (J-1)*INCX ) = 0
+            END DO
+            ALPHA = XNORM
+         END IF
+      ELSE
+*
+*        general case
+*
+         BETA = SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
+         RSAFMN = ONE / SAFMIN
+*
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL CSSCAL( 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 = SCNRM2( N-1, X, INCX )
+            ALPHA = CMPLX( ALPHR, ALPHI )
+            BETA = SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         END IF
+         ALPHA = ALPHA + BETA
+         IF( BETA.LT.ZERO ) THEN
+            BETA = -BETA
+            TAU = -ALPHA / BETA
+         ELSE
+            ALPHR = ALPHI * (ALPHI/REAL( ALPHA ))
+            ALPHR = ALPHR + XNORM * (XNORM/REAL( ALPHA ))
+            TAU = CMPLX( ALPHR/BETA, -ALPHI/BETA )
+            ALPHA = CMPLX( -ALPHR, ALPHI )
+         END IF
+         ALPHA = CLADIV( CMPLX( ONE ), ALPHA )
+         CALL CSCAL( N-1, ALPHA, X, INCX )
+*
+*        If BETA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of CLARFP
+*
+      END
diff --git a/SRC/clarft.f b/SRC/clarft.f
new file mode 100644
index 00000000..725b84d5
--- /dev/null
+++ b/SRC/clarft.f
@@ -0,0 +1,257 @@
+      SUBROUTINE CLARFT( 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            T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARFT 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 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) COMPLEX 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            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, PREVLASTV, LASTV
+      COMPLEX            VII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CLACGV, CTRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( LSAME( DIRECT, 'F' ) ) THEN
+         PREVLASTV = N
+         DO 20 I = 1, K
+            PREVLASTV = MAX( PREVLASTV, I )
+            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
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( LASTV, I ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i)
+*
+                  CALL CGEMV( 'Conjugate transpose', J-I+1, I-1,
+     $                        -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1,
+     $                        ZERO, T( 1, I ), 1 )
+               ELSE
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( I, LASTV ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)'
+*
+                  IF( I.LT.J )
+     $               CALL CLACGV( J-I, V( I, I+1 ), LDV )
+                  CALL CGEMV( 'No transpose', I-1, J-I+1, -TAU( I ),
+     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+     $                        T( 1, I ), 1 )
+                  IF( I.LT.J )
+     $               CALL CLACGV( J-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 CTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+     $                     LDT, T( 1, I ), 1 )
+               T( I, I ) = TAU( I )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MAX( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   20    CONTINUE
+      ELSE
+         PREVLASTV = 1
+         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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( LASTV, I ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i)
+*
+                     CALL CGEMV( 'Conjugate transpose', N-K+I-J+1, K-I,
+     $                           -TAU( I ), V( J, I+1 ), LDV, V( J, 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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( I, LASTV ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)'
+*
+                     CALL CLACGV( N-K+I-1-J+1, V( I, J ), LDV )
+                     CALL CGEMV( 'No transpose', K-I, N-K+I-J+1,
+     $                    -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
+     $                    ZERO, T( I+1, I ), 1 )
+                     CALL CLACGV( N-K+I-1-J+1, V( I, J ), 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 CTRMV( '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 )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MIN( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of CLARFT
+*
+      END
diff --git a/SRC/clarfx.f b/SRC/clarfx.f
new file mode 100644
index 00000000..2ab15b8e
--- /dev/null
+++ b/SRC/clarfx.f
@@ -0,0 +1,627 @@
+      SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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            TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARFX 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 array, dimension (M) if SIDE = 'L'
+*                                        or (N) if SIDE = 'R'
+*          The vector v in the representation of H.
+*
+*  TAU     (input) COMPLEX
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX 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 array, dimension (N) if SIDE = 'L'
+*                                            or (M) if SIDE = 'R'
+*          WORK is not referenced if H has order < 11.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J
+      COMPLEX            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           CLARF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+         CALL CLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( V4 )
+         V5 = CONJG( V( 5 ) )
+         T5 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( V4 )
+         V5 = CONJG( V( 5 ) )
+         T5 = TAU*CONJG( V5 )
+         V6 = CONJG( V( 6 ) )
+         T6 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( V4 )
+         V5 = CONJG( V( 5 ) )
+         T5 = TAU*CONJG( V5 )
+         V6 = CONJG( V( 6 ) )
+         T6 = TAU*CONJG( V6 )
+         V7 = CONJG( V( 7 ) )
+         T7 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( V4 )
+         V5 = CONJG( V( 5 ) )
+         T5 = TAU*CONJG( V5 )
+         V6 = CONJG( V( 6 ) )
+         T6 = TAU*CONJG( V6 )
+         V7 = CONJG( V( 7 ) )
+         T7 = TAU*CONJG( V7 )
+         V8 = CONJG( V( 8 ) )
+         T8 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( V4 )
+         V5 = CONJG( V( 5 ) )
+         T5 = TAU*CONJG( V5 )
+         V6 = CONJG( V( 6 ) )
+         T6 = TAU*CONJG( V6 )
+         V7 = CONJG( V( 7 ) )
+         T7 = TAU*CONJG( V7 )
+         V8 = CONJG( V( 8 ) )
+         T8 = TAU*CONJG( V8 )
+         V9 = CONJG( V( 9 ) )
+         T9 = TAU*CONJG( 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 = CONJG( V( 1 ) )
+         T1 = TAU*CONJG( V1 )
+         V2 = CONJG( V( 2 ) )
+         T2 = TAU*CONJG( V2 )
+         V3 = CONJG( V( 3 ) )
+         T3 = TAU*CONJG( V3 )
+         V4 = CONJG( V( 4 ) )
+         T4 = TAU*CONJG( V4 )
+         V5 = CONJG( V( 5 ) )
+         T5 = TAU*CONJG( V5 )
+         V6 = CONJG( V( 6 ) )
+         T6 = TAU*CONJG( V6 )
+         V7 = CONJG( V( 7 ) )
+         T7 = TAU*CONJG( V7 )
+         V8 = CONJG( V( 8 ) )
+         T8 = TAU*CONJG( V8 )
+         V9 = CONJG( V( 9 ) )
+         T9 = TAU*CONJG( V9 )
+         V10 = CONJG( V( 10 ) )
+         T10 = TAU*CONJG( V10 )
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+         CALL CLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*CONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*CONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*CONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*CONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*CONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*CONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*CONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*CONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*CONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*CONJG( V8 )
+         V9 = V( 9 )
+         T9 = TAU*CONJG( 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*CONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*CONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*CONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*CONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*CONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*CONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*CONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*CONJG( V8 )
+         V9 = V( 9 )
+         T9 = TAU*CONJG( V9 )
+         V10 = V( 10 )
+         T10 = TAU*CONJG( 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 RETURN
+*
+*     End of CLARFX
+*
+      END
diff --git a/SRC/clargv.f b/SRC/clargv.f
new file mode 100644
index 00000000..4579ff92
--- /dev/null
+++ b/SRC/clargv.f
@@ -0,0 +1,227 @@
+      SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * )
+      COMPLEX            X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARGV generates a vector of complex plane rotations with real
+*  cosines, determined by elements of the complex vectors x and y.
+*  For i = 1,2,...,n
+*
+*     (        c(i)   s(i) ) ( x(i) ) = ( r(i) )
+*     ( -conjg(s(i))  c(i) ) ( y(i) ) = (   0  )
+*
+*     where c(i)**2 + ABS(s(i))**2 = 1
+*
+*  The following conventions are used (these are the same as in CLARTG,
+*  but differ from the BLAS1 routine CROTG):
+*     If y(i)=0, then c(i)=1 and s(i)=0.
+*     If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be generated.
+*
+*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
+*          On entry, the vector x.
+*          On exit, x(i) is overwritten by r(i), for i = 1,...,n.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCY)
+*          On entry, the vector y.
+*          On exit, the sines of the plane rotations.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (output) REAL array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C. INCC > 0.
+*
+*  Further Details
+*  ======= =======
+*
+*  6-6-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 ..
+      REAL               TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0E+0, ONE = 1.0E+0, ZERO = 0.0E+0 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+*     LOGICAL            FIRST
+      INTEGER            COUNT, I, IC, IX, IY, J
+      REAL               CS, D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
+     $                   SAFMN2, SAFMX2, SCALE
+      COMPLEX            F, FF, FS, G, GS, R, SN
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           SLAMCH, SLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1, ABSSQ
+*     ..
+*     .. Save statement ..
+*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
+*     ..
+*     .. Data statements ..
+*     DATA               FIRST / .TRUE. /
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) )
+      ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2
+*     ..
+*     .. Executable Statements ..
+*
+*     IF( FIRST ) THEN
+*        FIRST = .FALSE.
+         SAFMIN = SLAMCH( 'S' )
+         EPS = SLAMCH( 'E' )
+         SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( SLAMCH( 'B' ) ) / TWO )
+         SAFMX2 = ONE / SAFMN2
+*     END IF
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 60 I = 1, N
+         F = X( IX )
+         G = Y( IY )
+*
+*        Use identical algorithm as in CLARTG
+*
+         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
+               GO TO 50
+            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 = SLAPY2( REAL( G ), AIMAG( G ) )
+*              Do complex/real division explicitly with two real
+*              divisions
+               D = SLAPY2( REAL( GS ), AIMAG( GS ) )
+               SN = CMPLX( REAL( GS ) / D, -AIMAG( GS ) / D )
+               GO TO 50
+            END IF
+            F2S = SLAPY2( REAL( FS ), AIMAG( 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 = SLAPY2( REAL( F ), AIMAG( F ) )
+               FF = CMPLX( REAL( F ) / D, AIMAG( F ) / D )
+            ELSE
+               DR = SAFMX2*REAL( F )
+               DI = SAFMX2*AIMAG( F )
+               D = SLAPY2( DR, DI )
+               FF = CMPLX( DR / D, DI / D )
+            END IF
+            SN = FF*CMPLX( REAL( GS ) / G2S, -AIMAG( 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 = CMPLX( F2S*REAL( FS ), F2S*AIMAG( FS ) )
+            CS = ONE / F2S
+            D = F2 + G2
+*           Do complex/real division explicitly with two real divisions
+            SN = CMPLX( REAL( R ) / D, AIMAG( R ) / D )
+            SN = SN*CONJG( GS )
+            IF( COUNT.NE.0 ) THEN
+               IF( COUNT.GT.0 ) THEN
+                  DO 30 J = 1, COUNT
+                     R = R*SAFMX2
+   30             CONTINUE
+               ELSE
+                  DO 40 J = 1, -COUNT
+                     R = R*SAFMN2
+   40             CONTINUE
+               END IF
+            END IF
+         END IF
+   50    CONTINUE
+         C( IC ) = CS
+         Y( IY ) = SN
+         X( IX ) = R
+         IC = IC + INCC
+         IY = IY + INCY
+         IX = IX + INCX
+   60 CONTINUE
+      RETURN
+*
+*     End of CLARGV
+*
+      END
diff --git a/SRC/clarnv.f b/SRC/clarnv.f
new file mode 100644
index 00000000..0795a07a
--- /dev/null
+++ b/SRC/clarnv.f
@@ -0,0 +1,130 @@
+      SUBROUTINE CLARNV( IDIST, ISEED, N, X )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IDIST, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISEED( 4 )
+      COMPLEX            X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARNV returns a vector of n random complex numbers from a uniform or
+*  normal distribution.
+*
+*  Arguments
+*  =========
+*
+*  IDIST   (input) INTEGER
+*          Specifies the distribution of the random numbers:
+*          = 1:  real and imaginary parts each uniform (0,1)
+*          = 2:  real and imaginary parts each uniform (-1,1)
+*          = 3:  real and imaginary parts each normal (0,1)
+*          = 4:  uniformly distributed on the disc abs(z) < 1
+*          = 5:  uniformly distributed on the circle abs(z) = 1
+*
+*  ISEED   (input/output) INTEGER array, dimension (4)
+*          On entry, the seed of the random number generator; the array
+*          elements must be between 0 and 4095, and ISEED(4) must be
+*          odd.
+*          On exit, the seed is updated.
+*
+*  N       (input) INTEGER
+*          The number of random numbers to be generated.
+*
+*  X       (output) COMPLEX array, dimension (N)
+*          The generated random numbers.
+*
+*  Further Details
+*  ===============
+*
+*  This routine calls the auxiliary routine SLARUV to generate random
+*  real numbers from a uniform (0,1) distribution, in batches of up to
+*  128 using vectorisable code. The Box-Muller method is used to
+*  transform numbers from a uniform to a normal distribution.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+      INTEGER            LV
+      PARAMETER          ( LV = 128 )
+      REAL               TWOPI
+      PARAMETER          ( TWOPI = 6.2831853071795864769252867663E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IL, IV
+*     ..
+*     .. Local Arrays ..
+      REAL               U( LV )
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX, EXP, LOG, MIN, SQRT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARUV
+*     ..
+*     .. Executable Statements ..
+*
+      DO 60 IV = 1, N, LV / 2
+         IL = MIN( LV / 2, N-IV+1 )
+*
+*        Call SLARUV to generate 2*IL real numbers from a uniform (0,1)
+*        distribution (2*IL <= LV)
+*
+         CALL SLARUV( ISEED, 2*IL, U )
+*
+         IF( IDIST.EQ.1 ) THEN
+*
+*           Copy generated numbers
+*
+            DO 10 I = 1, IL
+               X( IV+I-1 ) = CMPLX( U( 2*I-1 ), U( 2*I ) )
+   10       CONTINUE
+         ELSE IF( IDIST.EQ.2 ) THEN
+*
+*           Convert generated numbers to uniform (-1,1) distribution
+*
+            DO 20 I = 1, IL
+               X( IV+I-1 ) = CMPLX( TWO*U( 2*I-1 )-ONE,
+     $                       TWO*U( 2*I )-ONE )
+   20       CONTINUE
+         ELSE IF( IDIST.EQ.3 ) THEN
+*
+*           Convert generated numbers to normal (0,1) distribution
+*
+            DO 30 I = 1, IL
+               X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
+     $                       EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) )
+   30       CONTINUE
+         ELSE IF( IDIST.EQ.4 ) THEN
+*
+*           Convert generated numbers to complex numbers uniformly
+*           distributed on the unit disk
+*
+            DO 40 I = 1, IL
+               X( IV+I-1 ) = SQRT( U( 2*I-1 ) )*
+     $                       EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) )
+   40       CONTINUE
+         ELSE IF( IDIST.EQ.5 ) THEN
+*
+*           Convert generated numbers to complex numbers uniformly
+*           distributed on the unit circle
+*
+            DO 50 I = 1, IL
+               X( IV+I-1 ) = EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) )
+   50       CONTINUE
+         END IF
+   60 CONTINUE
+      RETURN
+*
+*     End of CLARNV
+*
+      END
diff --git a/SRC/clarrv.f b/SRC/clarrv.f
new file mode 100644
index 00000000..95cce4e5
--- /dev/null
+++ b/SRC/clarrv.f
@@ -0,0 +1,916 @@
+      SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN,
+     $                   ISPLIT, M, DOL, DOU, MINRGP,
+     $                   RTOL1, RTOL2, W, WERR, WGAP,
+     $                   IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            DOL, DOU, INFO, LDZ, M, N
+      REAL               MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+     $                   ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
+     $                   WGAP( * ), WORK( * )
+      COMPLEX           Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARRV computes the eigenvectors of the tridiagonal matrix
+*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
+*  The input eigenvalues should have been computed by SLARRE.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  VL      (input) REAL            
+*  VU      (input) REAL            
+*          Lower and upper bounds of the interval that contains the desired
+*          eigenvalues. VL < VU. Needed to compute gaps on the left or right
+*          end of the extremal eigenvalues in the desired RANGE.
+*
+*  D       (input/output) REAL             array, dimension (N)
+*          On entry, the N diagonal elements of the diagonal matrix D.
+*          On exit, D may be overwritten.
+*
+*  L       (input/output) REAL             array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the unit
+*          bidiagonal matrix L are in elements 1 to N-1 of L
+*          (if the matrix is not splitted.) At the end of each block
+*          is stored the corresponding shift as given by SLARRE.
+*          On exit, L is overwritten.
+*
+*  PIVMIN  (in) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence.
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*
+*  M       (input) INTEGER
+*          The total number of input eigenvalues.  0 <= M <= N.
+*
+*  DOL     (input) INTEGER
+*  DOU     (input) INTEGER
+*          If the user wants to compute only selected eigenvectors from all
+*          the eigenvalues supplied, he can specify an index range DOL:DOU.
+*          Or else the setting DOL=1, DOU=M should be applied.
+*          Note that DOL and DOU refer to the order in which the eigenvalues
+*          are stored in W.
+*          If the user wants to compute only selected eigenpairs, then
+*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+*          computed eigenvectors. All other columns of Z are set to zero.
+*
+*  MINRGP  (input) REAL            
+*
+*  RTOL1   (input) REAL            
+*  RTOL2   (input) REAL            
+*           Parameters for bisection.
+*           An interval [LEFT,RIGHT] has converged if
+*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+*  W       (input/output) REAL             array, dimension (N)
+*          The first M elements of W contain the APPROXIMATE eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block ( The output array
+*          W from SLARRE is expected here ). Furthermore, they are with
+*          respect to the shift of the corresponding root representation
+*          for their block. On exit, W holds the eigenvalues of the
+*          UNshifted matrix.
+*
+*  WERR    (input/output) REAL             array, dimension (N)
+*          The first M elements contain the semiwidth of the uncertainty
+*          interval of the corresponding eigenvalue in W
+*
+*  WGAP    (input/output) REAL             array, dimension (N)
+*          The separation from the right neighbor eigenvalue in W.
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The indices of the blocks (submatrices) associated with the
+*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+*          W(i) belongs to the first block from the top, =2 if W(i)
+*          belongs to the second block, etc.
+*
+*  INDEXW  (input) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+*  GERS    (input) REAL             array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+*          be computed from the original UNshifted matrix.
+*
+*  Z       (output) COMPLEX          array, dimension (LDZ, max(1,M) )
+*          If INFO = 0, the first M columns of Z contain the
+*          orthonormal eigenvectors of the matrix T
+*          corresponding to the input eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The I-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*I-1 ) through
+*          ISUPPZ( 2*I ).
+*
+*  WORK    (workspace) REAL             array, dimension (12*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (7*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*
+*          > 0:  A problem occured in CLARRV.
+*          < 0:  One of the called subroutines signaled an internal problem.
+*                Needs inspection of the corresponding parameter IINFO
+*                for further information.
+*
+*          =-1:  Problem in SLARRB when refining a child's eigenvalues.
+*          =-2:  Problem in SLARRF when computing the RRR of a child.
+*                When a child is inside a tight cluster, it can be difficult
+*                to find an RRR. A partial remedy from the user's point of
+*                view is to make the parameter MINRGP smaller and recompile.
+*                However, as the orthogonality of the computed vectors is
+*                proportional to 1/MINRGP, the user should be aware that
+*                he might be trading in precision when he decreases MINRGP.
+*          =-3:  Problem in SLARRB when refining a single eigenvalue
+*                after the Rayleigh correction was rejected.
+*          = 5:  The Rayleigh Quotient Iteration failed to converge to
+*                full accuracy in MAXITR steps.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXITR
+      PARAMETER          ( MAXITR = 10 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ) )
+      REAL               ZERO, ONE, TWO, THREE, FOUR, HALF
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
+     $                     TWO = 2.0E0, THREE = 3.0E0,
+     $                     FOUR = 4.0E0, HALF = 0.5E0)
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
+      INTEGER            DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
+     $                   IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
+     $                   INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
+     $                   ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
+     $                   NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
+     $                   NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
+     $                   OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
+     $                   WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
+     $                   ZUSEDW
+      INTEGER            INDIN1, INDIN2
+      REAL               BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
+     $                   LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
+     $                   RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
+     $                   SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLAR1V, CLASET, CSSCAL, SCOPY, SLARRB,
+     $                   SLARRF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS, REAL, MAX, MIN
+      INTRINSIC CMPLX
+*     ..
+*     .. Executable Statements ..
+*     ..
+
+*     The first N entries of WORK are reserved for the eigenvalues
+      INDLD = N+1
+      INDLLD= 2*N+1
+      INDIN1 = 3*N + 1
+      INDIN2 = 4*N + 1
+      INDWRK = 5*N + 1
+      MINWSIZE = 12 * N
+
+      DO 5 I= 1,MINWSIZE
+         WORK( I ) = ZERO
+ 5    CONTINUE
+
+*     IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
+*     factorization used to compute the FP vector
+      IINDR = 0
+*     IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
+*     layer and the one above.
+      IINDC1 = N
+      IINDC2 = 2*N
+      IINDWK = 3*N + 1
+
+      MINIWSIZE = 7 * N
+      DO 10 I= 1,MINIWSIZE
+         IWORK( I ) = 0
+ 10   CONTINUE
+
+      ZUSEDL = 1
+      IF(DOL.GT.1) THEN
+*        Set lower bound for use of Z
+         ZUSEDL = DOL-1
+      ENDIF
+      ZUSEDU = M
+      IF(DOU.LT.M) THEN
+*        Set lower bound for use of Z
+         ZUSEDU = DOU+1
+      ENDIF
+*     The width of the part of Z that is used
+      ZUSEDW = ZUSEDU - ZUSEDL + 1
+
+
+      CALL CLASET( 'Full', N, ZUSEDW, CZERO, CZERO,
+     $                    Z(1,ZUSEDL), LDZ )
+
+      EPS = SLAMCH( 'Precision' )
+      RQTOL = TWO * EPS
+*
+*     Set expert flags for standard code.
+      TRYRQC = .TRUE.
+
+      IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+      ELSE
+*        Only selected eigenpairs are computed. Since the other evalues
+*        are not refined by RQ iteration, bisection has to compute to full
+*        accuracy.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ENDIF
+
+*     The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
+*     desired eigenvalues. The support of the nonzero eigenvector
+*     entries is contained in the interval IBEGIN:IEND.
+*     Remark that if k eigenpairs are desired, then the eigenvectors
+*     are stored in k contiguous columns of Z.
+
+*     DONE is the number of eigenvectors already computed
+      DONE = 0
+      IBEGIN = 1
+      WBEGIN = 1
+      DO 170 JBLK = 1, IBLOCK( M )
+         IEND = ISPLIT( JBLK )
+         SIGMA = L( IEND )
+*        Find the eigenvectors of the submatrix indexed IBEGIN
+*        through IEND.
+         WEND = WBEGIN - 1
+ 15      CONTINUE
+         IF( WEND.LT.M ) THEN
+            IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+               WEND = WEND + 1
+               GO TO 15
+            END IF
+         END IF
+         IF( WEND.LT.WBEGIN ) THEN
+            IBEGIN = IEND + 1
+            GO TO 170
+         ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+            GO TO 170
+         END IF
+
+*        Find local spectral diameter of the block
+         GL = GERS( 2*IBEGIN-1 )
+         GU = GERS( 2*IBEGIN )
+         DO 20 I = IBEGIN+1 , IEND
+            GL = MIN( GERS( 2*I-1 ), GL )
+            GU = MAX( GERS( 2*I ), GU )
+ 20      CONTINUE
+         SPDIAM = GU - GL
+
+*        OLDIEN is the last index of the previous block
+         OLDIEN = IBEGIN - 1
+*        Calculate the size of the current block
+         IN = IEND - IBEGIN + 1
+*        The number of eigenvalues in the current block
+         IM = WEND - WBEGIN + 1
+
+*        This is for a 1x1 block
+         IF( IBEGIN.EQ.IEND ) THEN
+            DONE = DONE+1
+            Z( IBEGIN, WBEGIN ) = CMPLX( ONE, ZERO )
+            ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
+            ISUPPZ( 2*WBEGIN ) = IBEGIN
+            W( WBEGIN ) = W( WBEGIN ) + SIGMA
+            WORK( WBEGIN ) = W( WBEGIN )
+            IBEGIN = IEND + 1
+            WBEGIN = WBEGIN + 1
+            GO TO 170
+         END IF
+
+*        The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
+*        Note that these can be approximations, in this case, the corresp.
+*        entries of WERR give the size of the uncertainty interval.
+*        The eigenvalue approximations will be refined when necessary as
+*        high relative accuracy is required for the computation of the
+*        corresponding eigenvectors.
+         CALL SCOPY( IM, W( WBEGIN ), 1,
+     &                   WORK( WBEGIN ), 1 )
+
+*        We store in W the eigenvalue approximations w.r.t. the original
+*        matrix T.
+         DO 30 I=1,IM
+            W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 30      CONTINUE
+
+
+*        NDEPTH is the current depth of the representation tree
+         NDEPTH = 0
+*        PARITY is either 1 or 0
+         PARITY = 1
+*        NCLUS is the number of clusters for the next level of the
+*        representation tree, we start with NCLUS = 1 for the root
+         NCLUS = 1
+         IWORK( IINDC1+1 ) = 1
+         IWORK( IINDC1+2 ) = IM
+
+*        IDONE is the number of eigenvectors already computed in the current
+*        block
+         IDONE = 0
+*        loop while( IDONE.LT.IM )
+*        generate the representation tree for the current block and
+*        compute the eigenvectors
+   40    CONTINUE
+         IF( IDONE.LT.IM ) THEN
+*           This is a crude protection against infinitely deep trees
+            IF( NDEPTH.GT.M ) THEN
+               INFO = -2
+               RETURN
+            ENDIF
+*           breadth first processing of the current level of the representation
+*           tree: OLDNCL = number of clusters on current level
+            OLDNCL = NCLUS
+*           reset NCLUS to count the number of child clusters
+            NCLUS = 0
+*
+            PARITY = 1 - PARITY
+            IF( PARITY.EQ.0 ) THEN
+               OLDCLS = IINDC1
+               NEWCLS = IINDC2
+            ELSE
+               OLDCLS = IINDC2
+               NEWCLS = IINDC1
+            END IF
+*           Process the clusters on the current level
+            DO 150 I = 1, OLDNCL
+               J = OLDCLS + 2*I
+*              OLDFST, OLDLST = first, last index of current cluster.
+*                               cluster indices start with 1 and are relative
+*                               to WBEGIN when accessing W, WGAP, WERR, Z
+               OLDFST = IWORK( J-1 )
+               OLDLST = IWORK( J )
+               IF( NDEPTH.GT.0 ) THEN
+*                 Retrieve relatively robust representation (RRR) of cluster
+*                 that has been computed at the previous level
+*                 The RRR is stored in Z and overwritten once the eigenvectors
+*                 have been computed or when the cluster is refined
+
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Get representation from location of the leftmost evalue
+*                    of the cluster
+                     J = WBEGIN + OLDFST - 1
+                  ELSE
+                     IF(WBEGIN+OLDFST-1.LT.DOL) THEN
+*                       Get representation from the left end of Z array
+                        J = DOL - 1
+                     ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
+*                       Get representation from the right end of Z array
+                        J = DOU
+                     ELSE
+                        J = WBEGIN + OLDFST - 1
+                     ENDIF
+                  ENDIF
+                  DO 45 K = 1, IN - 1
+                     D( IBEGIN+K-1 ) = REAL( Z( IBEGIN+K-1,
+     $                                 J ) )
+                     L( IBEGIN+K-1 ) = REAL( Z( IBEGIN+K-1,
+     $                                 J+1 ) )
+   45             CONTINUE
+                  D( IEND ) = REAL( Z( IEND, J ) )
+                  SIGMA = REAL( Z( IEND, J+1 ) )
+
+*                 Set the corresponding entries in Z to zero
+                  CALL CLASET( 'Full', IN, 2, CZERO, CZERO,
+     $                         Z( IBEGIN, J), LDZ )
+               END IF
+
+*              Compute DL and DLL of current RRR
+               DO 50 J = IBEGIN, IEND-1
+                  TMP = D( J )*L( J )
+                  WORK( INDLD-1+J ) = TMP
+                  WORK( INDLLD-1+J ) = TMP*L( J )
+   50          CONTINUE
+
+               IF( NDEPTH.GT.0 ) THEN
+*                 P and Q are index of the first and last eigenvalue to compute
+*                 within the current block
+                  P = INDEXW( WBEGIN-1+OLDFST )
+                  Q = INDEXW( WBEGIN-1+OLDLST )
+*                 Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
+*                 thru' Q-OFFSET elements of these arrays are to be used.
+C                  OFFSET = P-OLDFST
+                  OFFSET = INDEXW( WBEGIN ) - 1
+*                 perform limited bisection (if necessary) to get approximate
+*                 eigenvalues to the precision needed.
+                  CALL SLARRB( IN, D( IBEGIN ),
+     $                         WORK(INDLLD+IBEGIN-1),
+     $                         P, Q, RTOL1, RTOL2, OFFSET,
+     $                         WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+     $                         WORK( INDWRK ), IWORK( IINDWK ),
+     $                         PIVMIN, SPDIAM, IN, IINFO )
+                  IF( IINFO.NE.0 ) THEN
+                     INFO = -1
+                     RETURN
+                  ENDIF
+*                 We also recompute the extremal gaps. W holds all eigenvalues
+*                 of the unshifted matrix and must be used for computation
+*                 of WGAP, the entries of WORK might stem from RRRs with
+*                 different shifts. The gaps from WBEGIN-1+OLDFST to
+*                 WBEGIN-1+OLDLST are correctly computed in SLARRB.
+*                 However, we only allow the gaps to become greater since
+*                 this is what should happen when we decrease WERR
+                  IF( OLDFST.GT.1) THEN
+                     WGAP( WBEGIN+OLDFST-2 ) =
+     $             MAX(WGAP(WBEGIN+OLDFST-2),
+     $                 W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
+     $                 - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
+                  ENDIF
+                  IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
+                     WGAP( WBEGIN+OLDLST-1 ) =
+     $               MAX(WGAP(WBEGIN+OLDLST-1),
+     $                   W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
+     $                   - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
+                  ENDIF
+*                 Each time the eigenvalues in WORK get refined, we store
+*                 the newly found approximation with all shifts applied in W
+                  DO 53 J=OLDFST,OLDLST
+                     W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
+ 53               CONTINUE
+               END IF
+
+*              Process the current node.
+               NEWFST = OLDFST
+               DO 140 J = OLDFST, OLDLST
+                  IF( J.EQ.OLDLST ) THEN
+*                    we are at the right end of the cluster, this is also the
+*                    boundary of the child cluster
+                     NEWLST = J
+                  ELSE IF ( WGAP( WBEGIN + J -1).GE.
+     $                    MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+*                    the right relative gap is big enough, the child cluster
+*                    (NEWFST,..,NEWLST) is well separated from the following
+                     NEWLST = J
+                   ELSE
+*                    inside a child cluster, the relative gap is not
+*                    big enough.
+                     GOTO 140
+                  END IF
+
+*                 Compute size of child cluster found
+                  NEWSIZ = NEWLST - NEWFST + 1
+
+*                 NEWFTT is the place in Z where the new RRR or the computed
+*                 eigenvector is to be stored
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Store representation at location of the leftmost evalue
+*                    of the cluster
+                     NEWFTT = WBEGIN + NEWFST - 1
+                  ELSE
+                     IF(WBEGIN+NEWFST-1.LT.DOL) THEN
+*                       Store representation at the left end of Z array
+                        NEWFTT = DOL - 1
+                     ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
+*                       Store representation at the right end of Z array
+                        NEWFTT = DOU
+                     ELSE
+                        NEWFTT = WBEGIN + NEWFST - 1
+                     ENDIF
+                  ENDIF
+
+                  IF( NEWSIZ.GT.1) THEN
+*
+*                    Current child is not a singleton but a cluster.
+*                    Compute and store new representation of child.
+*
+*
+*                    Compute left and right cluster gap.
+*
+*                    LGAP and RGAP are not computed from WORK because
+*                    the eigenvalue approximations may stem from RRRs
+*                    different shifts. However, W hold all eigenvalues
+*                    of the unshifted matrix. Still, the entries in WGAP
+*                    have to be computed from WORK since the entries
+*                    in W might be of the same order so that gaps are not
+*                    exhibited correctly for very close eigenvalues.
+                     IF( NEWFST.EQ.1 ) THEN
+                        LGAP = MAX( ZERO,
+     $                       W(WBEGIN)-WERR(WBEGIN) - VL )
+                    ELSE
+                        LGAP = WGAP( WBEGIN+NEWFST-2 )
+                     ENDIF
+                     RGAP = WGAP( WBEGIN+NEWLST-1 )
+*
+*                    Compute left- and rightmost eigenvalue of child
+*                    to high precision in order to shift as close
+*                    as possible and obtain as large relative gaps
+*                    as possible
+*
+                     DO 55 K =1,2
+                        IF(K.EQ.1) THEN
+                           P = INDEXW( WBEGIN-1+NEWFST )
+                        ELSE
+                           P = INDEXW( WBEGIN-1+NEWLST )
+                        ENDIF
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL SLARRB( IN, D(IBEGIN),
+     $                       WORK( INDLLD+IBEGIN-1 ),P,P,
+     $                       RQTOL, RQTOL, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       IN, IINFO )
+ 55                  CONTINUE
+*
+                     IF((WBEGIN+NEWLST-1.LT.DOL).OR.
+     $                  (WBEGIN+NEWFST-1.GT.DOU)) THEN
+*                       if the cluster contains no desired eigenvalues
+*                       skip the computation of that branch of the rep. tree
+*
+*                       We could skip before the refinement of the extremal
+*                       eigenvalues of the child, but then the representation
+*                       tree could be different from the one when nothing is
+*                       skipped. For this reason we skip at this place.
+                        IDONE = IDONE + NEWLST - NEWFST + 1
+                        GOTO 139
+                     ENDIF
+*
+*                    Compute RRR of child cluster.
+*                    Note that the new RRR is stored in Z
+*
+C                    SLARRF needs LWORK = 2*N
+                     CALL SLARRF( IN, D( IBEGIN ), L( IBEGIN ),
+     $                         WORK(INDLD+IBEGIN-1),
+     $                         NEWFST, NEWLST, WORK(WBEGIN),
+     $                         WGAP(WBEGIN), WERR(WBEGIN),
+     $                         SPDIAM, LGAP, RGAP, PIVMIN, TAU,
+     $                         WORK( INDIN1 ), WORK( INDIN2 ),
+     $                         WORK( INDWRK ), IINFO )
+*                    In the complex case, SLARRF cannot write
+*                    the new RRR directly into Z and needs an intermediate
+*                    workspace
+                     DO 56 K = 1, IN-1
+                        Z( IBEGIN+K-1, NEWFTT ) =
+     $                     CMPLX( WORK( INDIN1+K-1 ), ZERO )
+                        Z( IBEGIN+K-1, NEWFTT+1 ) =
+     $                     CMPLX( WORK( INDIN2+K-1 ), ZERO )
+   56                CONTINUE
+                     Z( IEND, NEWFTT ) =
+     $                  CMPLX( WORK( INDIN1+IN-1 ), ZERO )
+                     IF( IINFO.EQ.0 ) THEN
+*                       a new RRR for the cluster was found by SLARRF
+*                       update shift and store it
+                        SSIGMA = SIGMA + TAU
+                        Z( IEND, NEWFTT+1 ) = CMPLX( SSIGMA, ZERO )
+*                       WORK() are the midpoints and WERR() the semi-width
+*                       Note that the entries in W are unchanged.
+                        DO 116 K = NEWFST, NEWLST
+                           FUDGE =
+     $                          THREE*EPS*ABS(WORK(WBEGIN+K-1))
+                           WORK( WBEGIN + K - 1 ) =
+     $                          WORK( WBEGIN + K - 1) - TAU
+                           FUDGE = FUDGE +
+     $                          FOUR*EPS*ABS(WORK(WBEGIN+K-1))
+*                          Fudge errors
+                           WERR( WBEGIN + K - 1 ) =
+     $                          WERR( WBEGIN + K - 1 ) + FUDGE
+*                          Gaps are not fudged. Provided that WERR is small
+*                          when eigenvalues are close, a zero gap indicates
+*                          that a new representation is needed for resolving
+*                          the cluster. A fudge could lead to a wrong decision
+*                          of judging eigenvalues 'separated' which in
+*                          reality are not. This could have a negative impact
+*                          on the orthogonality of the computed eigenvectors.
+ 116                    CONTINUE
+
+                        NCLUS = NCLUS + 1
+                        K = NEWCLS + 2*NCLUS
+                        IWORK( K-1 ) = NEWFST
+                        IWORK( K ) = NEWLST
+                     ELSE
+                        INFO = -2
+                        RETURN
+                     ENDIF
+                  ELSE
+*
+*                    Compute eigenvector of singleton
+*
+                     ITER = 0
+*
+                     TOL = FOUR * LOG(REAL(IN)) * EPS
+*
+                     K = NEWFST
+                     WINDEX = WBEGIN + K - 1
+                     WINDMN = MAX(WINDEX - 1,1)
+                     WINDPL = MIN(WINDEX + 1,M)
+                     LAMBDA = WORK( WINDEX )
+                     DONE = DONE + 1
+*                    Check if eigenvector computation is to be skipped
+                     IF((WINDEX.LT.DOL).OR.
+     $                  (WINDEX.GT.DOU)) THEN
+                        ESKIP = .TRUE.
+                        GOTO 125
+                     ELSE
+                        ESKIP = .FALSE.
+                     ENDIF
+                     LEFT = WORK( WINDEX ) - WERR( WINDEX )
+                     RIGHT = WORK( WINDEX ) + WERR( WINDEX )
+                     INDEIG = INDEXW( WINDEX )
+*                    Note that since we compute the eigenpairs for a child,
+*                    all eigenvalue approximations are w.r.t the same shift.
+*                    In this case, the entries in WORK should be used for
+*                    computing the gaps since they exhibit even very small
+*                    differences in the eigenvalues, as opposed to the
+*                    entries in W which might "look" the same.
+
+                     IF( K .EQ. 1) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VL, the formula
+*                       LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
+*                       can lead to an overestimation of the left gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small left gap.
+                        LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        LGAP = WGAP(WINDMN)
+                     ENDIF
+                     IF( K .EQ. IM) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VU, the formula
+*                       can lead to an overestimation of the right gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small right gap.
+                        RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        RGAP = WGAP(WINDEX)
+                     ENDIF
+                     GAP = MIN( LGAP, RGAP )
+                     IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
+*                       The eigenvector support can become wrong
+*                       because significant entries could be cut off due to a
+*                       large GAPTOL parameter in LAR1V. Prevent this.
+                        GAPTOL = ZERO
+                     ELSE
+                        GAPTOL = GAP * EPS
+                     ENDIF
+                     ISUPMN = IN
+                     ISUPMX = 1
+*                    Update WGAP so that it holds the minimum gap
+*                    to the left or the right. This is crucial in the
+*                    case where bisection is used to ensure that the
+*                    eigenvalue is refined up to the required precision.
+*                    The correct value is restored afterwards.
+                     SAVGAP = WGAP(WINDEX)
+                     WGAP(WINDEX) = GAP
+*                    We want to use the Rayleigh Quotient Correction
+*                    as often as possible since it converges quadratically
+*                    when we are close enough to the desired eigenvalue.
+*                    However, the Rayleigh Quotient can have the wrong sign
+*                    and lead us away from the desired eigenvalue. In this
+*                    case, the best we can do is to use bisection.
+                     USEDBS = .FALSE.
+                     USEDRQ = .FALSE.
+*                    Bisection is initially turned off unless it is forced
+                     NEEDBS =  .NOT.TRYRQC
+ 120                 CONTINUE
+*                    Check if bisection should be used to refine eigenvalue
+                     IF(NEEDBS) THEN
+*                       Take the bisection as new iterate
+                        USEDBS = .TRUE.
+                        ITMP1 = IWORK( IINDR+WINDEX )
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL SLARRB( IN, D(IBEGIN),
+     $                       WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+     $                       ZERO, TWO*EPS, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       ITMP1, IINFO )
+                        IF( IINFO.NE.0 ) THEN
+                           INFO = -3
+                           RETURN
+                        ENDIF
+                        LAMBDA = WORK( WINDEX )
+*                       Reset twist index from inaccurate LAMBDA to
+*                       force computation of true MINGMA
+                        IWORK( IINDR+WINDEX ) = 0
+                     ENDIF
+*                    Given LAMBDA, compute the eigenvector.
+                     CALL CLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
+     $                    L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+     $                    WORK(INDLLD+IBEGIN-1),
+     $                    PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                    .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                    IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
+     $                    NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                     IF(ITER .EQ. 0) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ELSEIF(RESID.LT.BSTRES) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ENDIF
+                     ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
+                     ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
+                     ITER = ITER + 1
+
+*                    sin alpha <= |resid|/gap
+*                    Note that both the residual and the gap are
+*                    proportional to the matrix, so ||T|| doesn't play
+*                    a role in the quotient
+
+*
+*                    Convergence test for Rayleigh-Quotient iteration
+*                    (omitted when Bisection has been used)
+*
+                     IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
+     $                    RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
+     $                    THEN
+*                       We need to check that the RQCORR update doesn't
+*                       move the eigenvalue away from the desired one and
+*                       towards a neighbor. -> protection with bisection
+                        IF(INDEIG.LE.NEGCNT) THEN
+*                          The wanted eigenvalue lies to the left
+                           SGNDEF = -ONE
+                        ELSE
+*                          The wanted eigenvalue lies to the right
+                           SGNDEF = ONE
+                        ENDIF
+*                       We only use the RQCORR if it improves the
+*                       the iterate reasonably.
+                        IF( ( RQCORR*SGNDEF.GE.ZERO )
+     $                       .AND.( LAMBDA + RQCORR.LE. RIGHT)
+     $                       .AND.( LAMBDA + RQCORR.GE. LEFT)
+     $                       ) THEN
+                           USEDRQ = .TRUE.
+*                          Store new midpoint of bisection interval in WORK
+                           IF(SGNDEF.EQ.ONE) THEN
+*                             The current LAMBDA is on the left of the true
+*                             eigenvalue
+                              LEFT = LAMBDA
+*                             We prefer to assume that the error estimate
+*                             is correct. We could make the interval not
+*                             as a bracket but to be modified if the RQCORR
+*                             chooses to. In this case, the RIGHT side should
+*                             be modified as follows:
+*                              RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
+                           ELSE
+*                             The current LAMBDA is on the right of the true
+*                             eigenvalue
+                              RIGHT = LAMBDA
+*                             See comment about assuming the error estimate is
+*                             correct above.
+*                              LEFT = MIN(LEFT, LAMBDA + RQCORR)
+                           ENDIF
+                           WORK( WINDEX ) =
+     $                       HALF * (RIGHT + LEFT)
+*                          Take RQCORR since it has the correct sign and
+*                          improves the iterate reasonably
+                           LAMBDA = LAMBDA + RQCORR
+*                          Update width of error interval
+                           WERR( WINDEX ) =
+     $                             HALF * (RIGHT-LEFT)
+                        ELSE
+                           NEEDBS = .TRUE.
+                        ENDIF
+                        IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
+*                             The eigenvalue is computed to bisection accuracy
+*                             compute eigenvector and stop
+                           USEDBS = .TRUE.
+                           GOTO 120
+                        ELSEIF( ITER.LT.MAXITR ) THEN
+                           GOTO 120
+                        ELSEIF( ITER.EQ.MAXITR ) THEN
+                           NEEDBS = .TRUE.
+                           GOTO 120
+                        ELSE
+                           INFO = 5
+                           RETURN
+                        END IF
+                     ELSE
+                        STP2II = .FALSE.
+        IF(USEDRQ .AND. USEDBS .AND.
+     $                     BSTRES.LE.RESID) THEN
+                           LAMBDA = BSTW
+                           STP2II = .TRUE.
+                        ENDIF
+                        IF (STP2II) THEN
+*                          improve error angle by second step
+                           CALL CLAR1V( IN, 1, IN, LAMBDA,
+     $                          D( IBEGIN ), L( IBEGIN ),
+     $                          WORK(INDLD+IBEGIN-1),
+     $                          WORK(INDLLD+IBEGIN-1),
+     $                          PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                          .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                          IWORK( IINDR+WINDEX ),
+     $                          ISUPPZ( 2*WINDEX-1 ),
+     $                          NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                        ENDIF
+                        WORK( WINDEX ) = LAMBDA
+                     END IF
+*
+*                    Compute FP-vector support w.r.t. whole matrix
+*
+                     ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
+                     ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
+                     ZFROM = ISUPPZ( 2*WINDEX-1 )
+                     ZTO = ISUPPZ( 2*WINDEX )
+                     ISUPMN = ISUPMN + OLDIEN
+                     ISUPMX = ISUPMX + OLDIEN
+*                    Ensure vector is ok if support in the RQI has changed
+                     IF(ISUPMN.LT.ZFROM) THEN
+                        DO 122 II = ISUPMN,ZFROM-1
+                           Z( II, WINDEX ) = ZERO
+ 122                    CONTINUE
+                     ENDIF
+                     IF(ISUPMX.GT.ZTO) THEN
+                        DO 123 II = ZTO+1,ISUPMX
+                           Z( II, WINDEX ) = ZERO
+ 123                    CONTINUE
+                     ENDIF
+                     CALL CSSCAL( ZTO-ZFROM+1, NRMINV,
+     $                       Z( ZFROM, WINDEX ), 1 )
+ 125                 CONTINUE
+*                    Update W
+                     W( WINDEX ) = LAMBDA+SIGMA
+*                    Recompute the gaps on the left and right
+*                    But only allow them to become larger and not
+*                    smaller (which can only happen through "bad"
+*                    cancellation and doesn't reflect the theory
+*                    where the initial gaps are underestimated due
+*                    to WERR being too crude.)
+                     IF(.NOT.ESKIP) THEN
+                        IF( K.GT.1) THEN
+                           WGAP( WINDMN ) = MAX( WGAP(WINDMN),
+     $                          W(WINDEX)-WERR(WINDEX)
+     $                          - W(WINDMN)-WERR(WINDMN) )
+                        ENDIF
+                        IF( WINDEX.LT.WEND ) THEN
+                           WGAP( WINDEX ) = MAX( SAVGAP,
+     $                          W( WINDPL )-WERR( WINDPL )
+     $                          - W( WINDEX )-WERR( WINDEX) )
+                        ENDIF
+                     ENDIF
+                     IDONE = IDONE + 1
+                  ENDIF
+*                 here ends the code for the current child
+*
+ 139              CONTINUE
+*                 Proceed to any remaining child nodes
+                  NEWFST = J + 1
+ 140           CONTINUE
+ 150        CONTINUE
+            NDEPTH = NDEPTH + 1
+            GO TO 40
+         END IF
+         IBEGIN = IEND + 1
+         WBEGIN = WEND + 1
+ 170  CONTINUE
+*
+
+      RETURN
+*
+*     End of CLARRV
+*
+      END
diff --git a/SRC/clartg.f b/SRC/clartg.f
new file mode 100644
index 00000000..c521d330
--- /dev/null
+++ b/SRC/clartg.f
@@ -0,0 +1,195 @@
+      SUBROUTINE CLARTG( 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 ..
+      REAL               CS
+      COMPLEX            F, G, R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARTG 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 CROTG, 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
+*          The first component of vector to be rotated.
+*
+*  G       (input) COMPLEX
+*          The second component of vector to be rotated.
+*
+*  CS      (output) REAL
+*          The cosine of the rotation.
+*
+*  SN      (output) COMPLEX
+*          The sine of the rotation.
+*
+*  R       (output) COMPLEX
+*          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 ..
+      REAL               TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0E+0, ONE = 1.0E+0, ZERO = 0.0E+0 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+*     LOGICAL            FIRST
+      INTEGER            COUNT, I
+      REAL               D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
+     $                   SAFMN2, SAFMX2, SCALE
+      COMPLEX            FF, FS, GS
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           SLAMCH, SLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, INT, LOG, MAX, REAL,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1, ABSSQ
+*     ..
+*     .. Save statement ..
+*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
+*     ..
+*     .. Data statements ..
+*     DATA               FIRST / .TRUE. /
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( FF ) = MAX( ABS( REAL( FF ) ), ABS( AIMAG( FF ) ) )
+      ABSSQ( FF ) = REAL( FF )**2 + AIMAG( FF )**2
+*     ..
+*     .. Executable Statements ..
+*
+*     IF( FIRST ) THEN
+         SAFMIN = SLAMCH( 'S' )
+         EPS = SLAMCH( 'E' )
+         SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( SLAMCH( '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 = SLAPY2( REAL( G ), AIMAG( G ) )
+*           Do complex/real division explicitly with two real divisions
+            D = SLAPY2( REAL( GS ), AIMAG( GS ) )
+            SN = CMPLX( REAL( GS ) / D, -AIMAG( GS ) / D )
+            RETURN
+         END IF
+         F2S = SLAPY2( REAL( FS ), AIMAG( 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 = SLAPY2( REAL( F ), AIMAG( F ) )
+            FF = CMPLX( REAL( F ) / D, AIMAG( F ) / D )
+         ELSE
+            DR = SAFMX2*REAL( F )
+            DI = SAFMX2*AIMAG( F )
+            D = SLAPY2( DR, DI )
+            FF = CMPLX( DR / D, DI / D )
+         END IF
+         SN = FF*CMPLX( REAL( GS ) / G2S, -AIMAG( 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 = CMPLX( F2S*REAL( FS ), F2S*AIMAG( FS ) )
+         CS = ONE / F2S
+         D = F2 + G2
+*        Do complex/real division explicitly with two real divisions
+         SN = CMPLX( REAL( R ) / D, AIMAG( R ) / D )
+         SN = SN*CONJG( 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 CLARTG
+*
+      END
diff --git a/SRC/clartv.f b/SRC/clartv.f
new file mode 100644
index 00000000..553a2ded
--- /dev/null
+++ b/SRC/clartv.f
@@ -0,0 +1,78 @@
+      SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * )
+      COMPLEX            S( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARTV applies a vector of complex plane rotations with real cosines
+*  to elements of the complex vectors x and y. For i = 1,2,...,n
+*
+*     ( x(i) ) := (        c(i)   s(i) ) ( x(i) )
+*     ( y(i) )    ( -conjg(s(i))  c(i) ) ( y(i) )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
+*          The vector x.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCY)
+*          The vector y.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (input) REAL array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) COMPLEX array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX, IY
+      COMPLEX            XI, YI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = X( IX )
+         YI = Y( IY )
+         X( IX ) = C( IC )*XI + S( IC )*YI
+         Y( IY ) = C( IC )*YI - CONJG( S( IC ) )*XI
+         IX = IX + INCX
+         IY = IY + INCY
+         IC = IC + INCC
+   10 CONTINUE
+      RETURN
+*
+*     End of CLARTV
+*
+      END
diff --git a/SRC/clarz.f b/SRC/clarz.f
new file mode 100644
index 00000000..9bf7efbb
--- /dev/null
+++ b/SRC/clarz.f
@@ -0,0 +1,157 @@
+      SUBROUTINE CLARZ( 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            TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARZ 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 CTZRZF.
+*
+*  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 array, dimension (1+(L-1)*abs(INCV))
+*          The vector v in the representation of H as returned by
+*          CTZRZF. V is not used if TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) COMPLEX
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX 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 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            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMV, CGERC, CGERU, CLACGV
+*     ..
+*     .. 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 CCOPY( N, C, LDC, WORK, 1 )
+            CALL CLACGV( N, WORK, 1 )
+*
+*           w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) )
+*
+            CALL CGEMV( 'Conjugate transpose', L, N, ONE, C( M-L+1, 1 ),
+     $                  LDC, V, INCV, ONE, WORK, 1 )
+            CALL CLACGV( N, WORK, 1 )
+*
+*           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
+*
+            CALL CAXPY( 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 CGERU( 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 CCOPY( M, C, 1, WORK, 1 )
+*
+*           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
+*
+            CALL CGEMV( '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 CAXPY( 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 CGERC( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
+     $                  LDC )
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of CLARZ
+*
+      END
diff --git a/SRC/clarzb.f b/SRC/clarzb.f
new file mode 100644
index 00000000..77e24ba5
--- /dev/null
+++ b/SRC/clarzb.f
@@ -0,0 +1,234 @@
+      SUBROUTINE CLARZB( 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            C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARZB 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 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 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 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMM, CLACGV, CTRMM, 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( 'CLARZB', -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 CCOPY( 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 CGEMM( '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 CTRMM( '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 CGEMM( '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 CCOPY( 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 CGEMM( '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 CLACGV( K-J+1, T( J, J ), 1 )
+   50    CONTINUE
+         CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
+     $               LDT, WORK, LDWORK )
+         DO 60 J = 1, K
+            CALL CLACGV( 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 CLACGV( K, V( 1, J ), 1 )
+   90    CONTINUE
+         IF( L.GT.0 )
+     $      CALL CGEMM( '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 CLACGV( K, V( 1, J ), 1 )
+  100    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of CLARZB
+*
+      END
diff --git a/SRC/clarzt.f b/SRC/clarzt.f
new file mode 100644
index 00000000..59260cae
--- /dev/null
+++ b/SRC/clarzt.f
@@ -0,0 +1,186 @@
+      SUBROUTINE CLARZT( 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            T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLARZT 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 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CLACGV, CTRMV, 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( 'CLARZT', -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 CLACGV( N, V( I, 1 ), LDV )
+               CALL CGEMV( 'No transpose', K-I, N, -TAU( I ),
+     $                     V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                     T( I+1, I ), 1 )
+               CALL CLACGV( N, V( I, 1 ), LDV )
+*
+*              T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+               CALL CTRMV( '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 CLARZT
+*
+      END
diff --git a/SRC/clascl.f b/SRC/clascl.f
new file mode 100644
index 00000000..4f18e904
--- /dev/null
+++ b/SRC/clascl.f
@@ -0,0 +1,283 @@
+      SUBROUTINE CLASCL( 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
+      REAL               CFROM, CTO
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLASCL 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) REAL
+*  CTO     (input) REAL
+*          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 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      INTEGER            I, ITYPE, J, K1, K2, K3, K4
+      REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, SISNAN
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH, SISNAN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
+         INFO = -4
+      ELSE IF( SISNAN(CTO) ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      IF( CFROM1.EQ.CFROMC ) THEN
+!        CFROMC is an inf.  Multiply by a correctly signed zero for
+!        finite CTOC, or a NaN if CTOC is infinite.
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+         CTO1 = CTOC
+      ELSE
+         CTO1 = CTOC / BIGNUM
+         IF( CTO1.EQ.CTOC ) THEN
+!           CTOC is either 0 or an inf.  In both cases, CTOC itself
+!           serves as the correct multiplication factor.
+            MUL = CTOC
+            DONE = .TRUE.
+            CFROMC = ONE
+         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+            MUL = SMLNUM
+            DONE = .FALSE.
+            CFROMC = CFROM1
+         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+            MUL = BIGNUM
+            DONE = .FALSE.
+            CTOC = CTO1
+         ELSE
+            MUL = CTOC / CFROMC
+            DONE = .TRUE.
+         END IF
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of CLASCL
+*
+      END
diff --git a/SRC/claset.f b/SRC/claset.f
new file mode 100644
index 00000000..c47b7d7e
--- /dev/null
+++ b/SRC/claset.f
@@ -0,0 +1,114 @@
+      SUBROUTINE CLASET( 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            ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLASET 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
+*          All the offdiagonal array elements are set to ALPHA.
+*
+*  BETA    (input) COMPLEX
+*          All the diagonal array elements are set to BETA.
+*
+*  A       (input/output) COMPLEX 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 CLASET
+*
+      END
diff --git a/SRC/clasr.f b/SRC/clasr.f
new file mode 100644
index 00000000..74e412ce
--- /dev/null
+++ b/SRC/clasr.f
@@ -0,0 +1,363 @@
+      SUBROUTINE CLASR( 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 ..
+      REAL               C( * ), S( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLASR 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) REAL array, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          The cosines c(k) of the plane rotations.
+*
+*  S       (input) REAL 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 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+      REAL               CTEMP, STEMP
+      COMPLEX            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( 'CLASR ', 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 CLASR
+*
+      END
diff --git a/SRC/classq.f b/SRC/classq.f
new file mode 100644
index 00000000..f4b4120d
--- /dev/null
+++ b/SRC/classq.f
@@ -0,0 +1,101 @@
+      SUBROUTINE CLASSQ( 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
+      REAL               SCALE, SUMSQ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLASSQ 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 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) REAL
+*          On entry, the value  scale  in the equation above.
+*          On exit, SCALE is overwritten with the value  scl .
+*
+*  SUMSQ   (input/output) REAL
+*          On entry, the value  sumsq  in the equation above.
+*          On exit, SUMSQ is overwritten with the value  ssq .
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IX
+      REAL               TEMP1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.GT.0 ) THEN
+         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
+            IF( REAL( X( IX ) ).NE.ZERO ) THEN
+               TEMP1 = ABS( REAL( 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( AIMAG( X( IX ) ).NE.ZERO ) THEN
+               TEMP1 = ABS( AIMAG( 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 CLASSQ
+*
+      END
diff --git a/SRC/claswp.f b/SRC/claswp.f
new file mode 100644
index 00000000..0ea8f165
--- /dev/null
+++ b/SRC/claswp.f
@@ -0,0 +1,119 @@
+      SUBROUTINE CLASWP( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLASWP 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 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            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 CLASWP
+*
+      END
diff --git a/SRC/clasyf.f b/SRC/clasyf.f
new file mode 100644
index 00000000..8d1ae0c9
--- /dev/null
+++ b/SRC/clasyf.f
@@ -0,0 +1,597 @@
+      SUBROUTINE CLASYF( 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( * )
+      COMPLEX            A( LDA, * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLASYF computes a partial factorization of a complex 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.
+*  Note that U' denotes the transpose of U.
+*
+*  CLASYF is an auxiliary routine called by CSYTRF. 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) COMPLEX 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) COMPLEX 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+     $                   KSTEP, KW
+      REAL               ABSAKK, ALPHA, COLMAX, ROWMAX
+      COMPLEX            D11, D21, D22, R1, T, Z
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      EXTERNAL           LSAME, ICAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMM, CGEMV, CSCAL, CSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+*     ..
+*     .. 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 CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+         IF( K.LT.N )
+     $      CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+     $                  W( K, KW+1 ), LDW, CONE, 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 = CABS1( 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 = ICAMAX( K-1, W( 1, KW ), 1 )
+            COLMAX = CABS1( 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 CCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+               CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+     $                     W( IMAX+1, KW-1 ), 1 )
+               IF( K.LT.N )
+     $            CALL CGEMV( 'No transpose', K, N-K, -CONE,
+     $                        A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+     $                        CONE, 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 + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, KW-1 ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 CCOPY( 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 CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+*              Interchange rows KK and KP in last KK columns of A and W
+*
+               CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+               CALL CSWAP( 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 CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+               R1 = CONE / A( K, K )
+               CALL CSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+     $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+     $                     A( J, JJ ), 1 )
+   40       CONTINUE
+*
+*           Update the rectangular superdiagonal block
+*
+            CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+     $                  -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+     $                  CONE, 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 CSWAP( 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 CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+         CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
+     $               W( K, 1 ), LDW, CONE, 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 = CABS1( 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 + ICAMAX( N-K, W( K+1, K ), 1 )
+            COLMAX = CABS1( 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 CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+               CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
+     $                     1 )
+               CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+     $                     LDA, W( IMAX, 1 ), LDW, CONE, 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 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, K+1 ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 CCOPY( 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 CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+               CALL CCOPY( 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 CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+               CALL CSWAP( 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 CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+               IF( K.LT.N ) THEN
+                  R1 = CONE / A( K, K )
+                  CALL CSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+     $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+     $                     A( JJ, JJ ), 1 )
+  100       CONTINUE
+*
+*           Update the rectangular subdiagonal block
+*
+            IF( J+JB.LE.N )
+     $         CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+     $                     K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+     $                     LDW, CONE, 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 CSWAP( 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 CLASYF
+*
+      END
diff --git a/SRC/clatbs.f b/SRC/clatbs.f
new file mode 100644
index 00000000..aa48c9c0
--- /dev/null
+++ b/SRC/clatbs.f
@@ -0,0 +1,908 @@
+      SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, 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, KD, LDAB, N
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               CNORM( * )
+      COMPLEX            AB( LDAB, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLATBS 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, where A is an upper or lower
+*  triangular band matrix.  Here 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 CTBSV 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.
+*
+*  KD      (input) INTEGER
+*          The number of subdiagonals or superdiagonals in the
+*          triangular matrix A.  KD >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first KD+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  X       (input/output) COMPLEX 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) REAL
+*          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) REAL 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, CTBSV
+*  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 CTBSV 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 CTBSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0,
+     $                   TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
+      REAL               BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
+     $                   XBND, XJ, XMAX
+      COMPLEX            CSUMJ, TJJS, USCAL, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX, ISAMAX
+      REAL               SCASUM, SLAMCH
+      COMPLEX            CDOTC, CDOTU, CLADIV
+      EXTERNAL           LSAME, ICAMAX, ISAMAX, SCASUM, SLAMCH, CDOTC,
+     $                   CDOTU, CLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CSSCAL, CTBSV, SLABAD, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1, CABS2
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+      CABS2( ZDUM ) = ABS( REAL( ZDUM ) / 2. ) +
+     $                ABS( AIMAG( ZDUM ) / 2. )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLATBS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = SLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM / SLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            DO 10 J = 1, N
+               JLEN = MIN( KD, J-1 )
+               CNORM( J ) = SCASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N
+               JLEN = MIN( KD, N-J )
+               IF( JLEN.GT.0 ) THEN
+                  CNORM( J ) = SCASUM( JLEN, AB( 2, J ), 1 )
+               ELSE
+                  CNORM( J ) = ZERO
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM/2.
+*
+      IMAX = ISAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM*HALF ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = HALF / ( SMLNUM*TMAX )
+         CALL SSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine CTBSV 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
+            MAIND = KD + 1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+            MAIND = 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 = AB( MAIND, 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
+            MAIND = KD + 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+            MAIND = 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 = AB( MAIND, 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 CTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, 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 CSSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         ELSE
+            XMAX = XMAX*TWO
+         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 = CABS1( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = AB( MAIND, J )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 105
+               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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = CLADIV( 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
+  105          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 CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL CSSCAL( N, HALF, X, 1 )
+                  SCALE = SCALE*HALF
+               END IF
+*
+               IF( UPPER ) THEN
+                  IF( J.GT.1 ) THEN
+*
+*                    Compute the update
+*                       x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
+*                                             x(j)* A(max(1,j-kd):j-1,j)
+*
+                     JLEN = MIN( KD, J-1 )
+                     CALL CAXPY( JLEN, -X( J )*TSCAL,
+     $                           AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
+                     I = ICAMAX( J-1, X, 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+               ELSE IF( J.LT.N ) THEN
+*
+*                 Compute the update
+*                    x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
+*                                          x(j) * A(j+1:min(j+kd,n),j)
+*
+                  JLEN = MIN( KD, N-J )
+                  IF( JLEN.GT.0 )
+     $               CALL CAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
+     $                           X( J+1 ), 1 )
+                  I = J + ICAMAX( N-J, X( J+1 ), 1 )
+                  XMAX = CABS1( X( I ) )
+               END IF
+  110       CONTINUE
+*
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Solve A**T * x = b
+*
+            DO 150 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 = AB( MAIND, 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 = CLADIV( USCAL, TJJS )
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.CMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call CDOTU to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     CSUMJ = CDOTU( JLEN, AB( KD+1-JLEN, J ), 1,
+     $                       X( J-JLEN ), 1 )
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     IF( JLEN.GT.1 )
+     $                  CSUMJ = CDOTU( JLEN, AB( 2, J ), 1, X( J+1 ),
+     $                          1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     DO 120 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
+     $                          X( J-JLEN-1+I )
+  120                CONTINUE
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     DO 130 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
+  130                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.CMPLX( 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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AB( MAIND, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 145
+                  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/abs(x(j)).
+*
+                              REC = ONE / XJ
+                              CALL CSSCAL( N, REC, X, 1 )
+                              SCALE = SCALE*REC
+                              XMAX = XMAX*REC
+                           END IF
+                        END IF
+                        X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                        X( J ) = CLADIV( X( J ), TJJS )
+                     ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0 and compute a solution to A**T *x = 0.
+*
+                        DO 140 I = 1, N
+                           X( I ) = ZERO
+  140                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  145             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 ) = CLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+  150       CONTINUE
+*
+         ELSE
+*
+*           Solve A**H * x = b
+*
+            DO 190 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 = CONJG( AB( MAIND, 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 = CLADIV( USCAL, TJJS )
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.CMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call CDOTC to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     CSUMJ = CDOTC( JLEN, AB( KD+1-JLEN, J ), 1,
+     $                       X( J-JLEN ), 1 )
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     IF( JLEN.GT.1 )
+     $                  CSUMJ = CDOTC( JLEN, AB( 2, J ), 1, X( J+1 ),
+     $                          1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     DO 160 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( CONJG( AB( KD+I-JLEN, J ) )*
+     $                          USCAL )*X( J-JLEN-1+I )
+  160                CONTINUE
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     DO 170 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( CONJG( AB( I+1, J ) )*USCAL )*
+     $                          X( J+I )
+  170                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.CMPLX( 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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = CONJG( AB( MAIND, J ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 185
+                  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/abs(x(j)).
+*
+                              REC = ONE / XJ
+                              CALL CSSCAL( N, REC, X, 1 )
+                              SCALE = SCALE*REC
+                              XMAX = XMAX*REC
+                           END IF
+                        END IF
+                        X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                        X( J ) = CLADIV( 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 180 I = 1, N
+                           X( I ) = ZERO
+  180                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  185             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 ) = CLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+  190       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of CLATBS
+*
+      END
diff --git a/SRC/clatdf.f b/SRC/clatdf.f
new file mode 100644
index 00000000..39b12163
--- /dev/null
+++ b/SRC/clatdf.f
@@ -0,0 +1,241 @@
+      SUBROUTINE CLATDF( 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
+      REAL               RDSCAL, RDSUM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      COMPLEX            RHS( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLATDF 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 CGETC2. On entry RHS = f holds the
+*  contribution from earlier solved sub-systems, and on return RHS = x.
+*
+*  The factorization of Z returned by CGETC2 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 CGECON, 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) REAL array, dimension (LDZ, N)
+*          On entry, the LU part of the factorization of the n-by-n
+*          matrix Z computed by CGETC2:  Z = P * L * U * Q
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDA >= max(1, N).
+*
+*  RHS     (input/output) REAL 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) REAL
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by CTGSYL, 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 CTGSY2 is called by CTGSYL.
+*
+*  RDSCAL  (input/output) REAL
+*          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 CTGSY2 is called by
+*          CTGSYL.
+*
+*  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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J, K
+      REAL               RTEMP, SCALE, SMINU, SPLUS
+      COMPLEX            BM, BP, PMONE, TEMP
+*     ..
+*     .. Local Arrays ..
+      REAL               RWORK( MAXDIM )
+      COMPLEX            WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGECON, CGESC2, CLASSQ, CLASWP,
+     $                   CSCAL
+*     ..
+*     .. External Functions ..
+      REAL               SCASUM
+      COMPLEX            CDOTC
+      EXTERNAL           SCASUM, CDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( IJOB.NE.2 ) THEN
+*
+*        Apply permutations IPIV to RHS
+*
+         CALL CLASWP( 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 + REAL( CDOTC( N-J, Z( J+1, J ), 1, Z( J+1,
+     $              J ), 1 ) )
+            SMINU = REAL( CDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) )
+            SPLUS = SPLUS*REAL( 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 CAXPY( 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 CCOPY( 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 CCOPY( N, WORK, 1, RHS, 1 )
+*
+*        Apply the permutations JPIV to the computed solution (RHS)
+*
+         CALL CLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
+*
+*        Compute the sum of squares
+*
+         CALL CLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+         RETURN
+      END IF
+*
+*     ENTRY IJOB = 2
+*
+*     Compute approximate nullvector XM of Z
+*
+      CALL CGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO )
+      CALL CCOPY( N, WORK( N+1 ), 1, XM, 1 )
+*
+*     Compute RHS
+*
+      CALL CLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
+      TEMP = CONE / SQRT( CDOTC( N, XM, 1, XM, 1 ) )
+      CALL CSCAL( N, TEMP, XM, 1 )
+      CALL CCOPY( N, XM, 1, XP, 1 )
+      CALL CAXPY( N, CONE, RHS, 1, XP, 1 )
+      CALL CAXPY( N, -CONE, XM, 1, RHS, 1 )
+      CALL CGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE )
+      CALL CGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE )
+      IF( SCASUM( N, XP, 1 ).GT.SCASUM( N, RHS, 1 ) )
+     $   CALL CCOPY( N, XP, 1, RHS, 1 )
+*
+*     Compute the sum of squares
+*
+      CALL CLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+      RETURN
+*
+*     End of CLATDF
+*
+      END
diff --git a/SRC/clatps.f b/SRC/clatps.f
new file mode 100644
index 00000000..9f91ee3a
--- /dev/null
+++ b/SRC/clatps.f
@@ -0,0 +1,894 @@
+      SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, 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, N
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               CNORM( * )
+      COMPLEX            AP( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLATPS 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, where A is an upper or lower
+*  triangular matrix stored in packed form.  Here 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 CTPSV 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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  X       (input/output) COMPLEX 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) REAL
+*          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) REAL 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, CTPSV
+*  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 CTPSV 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 CTPSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0,
+     $                   TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
+      REAL               BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
+     $                   XBND, XJ, XMAX
+      COMPLEX            CSUMJ, TJJS, USCAL, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX, ISAMAX
+      REAL               SCASUM, SLAMCH
+      COMPLEX            CDOTC, CDOTU, CLADIV
+      EXTERNAL           LSAME, ICAMAX, ISAMAX, SCASUM, SLAMCH, CDOTC,
+     $                   CDOTU, CLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CSSCAL, CTPSV, SLABAD, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1, CABS2
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+      CABS2( ZDUM ) = ABS( REAL( ZDUM ) / 2. ) +
+     $                ABS( AIMAG( ZDUM ) / 2. )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CLATPS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = SLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM / SLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            IP = 1
+            DO 10 J = 1, N
+               CNORM( J ) = SCASUM( J-1, AP( IP ), 1 )
+               IP = IP + J
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            IP = 1
+            DO 20 J = 1, N - 1
+               CNORM( J ) = SCASUM( N-J, AP( IP+1 ), 1 )
+               IP = IP + N - J + 1
+   20       CONTINUE
+            CNORM( N ) = ZERO
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM/2.
+*
+      IMAX = ISAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM*HALF ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = HALF / ( SMLNUM*TMAX )
+         CALL SSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine CTPSV 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
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = N
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 60
+*
+               TJJS = AP( IP )
+               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
+               IP = IP + JINC*JLEN
+               JLEN = JLEN - 1
+   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
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            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 = AP( IP )
+               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
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+   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 CTPSV( UPLO, TRANS, DIAG, N, AP, 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 CSSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         ELSE
+            XMAX = XMAX*TWO
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            DO 110 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = CABS1( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = AP( IP )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 105
+               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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = CLADIV( 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
+  105          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 CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL CSSCAL( 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 CAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
+     $                           1 )
+                     I = ICAMAX( J-1, X, 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+                  IP = IP - J
+               ELSE
+                  IF( J.LT.N ) THEN
+*
+*                    Compute the update
+*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+                     CALL CAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + ICAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+                  IP = IP + N - J + 1
+               END IF
+  110       CONTINUE
+*
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Solve A**T * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            DO 150 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 = AP( IP )*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 = CLADIV( USCAL, TJJS )
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.CMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call CDOTU to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     CSUMJ = CDOTU( J-1, AP( IP-J+1 ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = CDOTU( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 120 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( AP( IP-J+I )*USCAL )*X( I )
+  120                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 130 I = 1, N - J
+                        CSUMJ = CSUMJ + ( AP( IP+I )*USCAL )*X( J+I )
+  130                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.CMPLX( 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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AP( IP )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 145
+                  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/abs(x(j)).
+*
+                              REC = ONE / XJ
+                              CALL CSSCAL( N, REC, X, 1 )
+                              SCALE = SCALE*REC
+                              XMAX = XMAX*REC
+                           END IF
+                        END IF
+                        X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                        X( J ) = CLADIV( X( J ), TJJS )
+                     ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0 and compute a solution to A**T *x = 0.
+*
+                        DO 140 I = 1, N
+                           X( I ) = ZERO
+  140                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  145             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 ) = CLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+  150       CONTINUE
+*
+         ELSE
+*
+*           Solve A**H * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            DO 190 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 = CONJG( AP( IP ) )*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 = CLADIV( USCAL, TJJS )
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.CMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call CDOTC to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     CSUMJ = CDOTC( J-1, AP( IP-J+1 ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = CDOTC( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 160 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( CONJG( AP( IP-J+I ) )*USCAL )*
+     $                          X( I )
+  160                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 170 I = 1, N - J
+                        CSUMJ = CSUMJ + ( CONJG( AP( IP+I ) )*USCAL )*
+     $                          X( J+I )
+  170                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.CMPLX( 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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = CONJG( AP( IP ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 185
+                  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/abs(x(j)).
+*
+                              REC = ONE / XJ
+                              CALL CSSCAL( N, REC, X, 1 )
+                              SCALE = SCALE*REC
+                              XMAX = XMAX*REC
+                           END IF
+                        END IF
+                        X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                        X( J ) = CLADIV( 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 180 I = 1, N
+                           X( I ) = ZERO
+  180                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  185             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 ) = CLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+  190       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of CLATPS
+*
+      END
diff --git a/SRC/clatrd.f b/SRC/clatrd.f
new file mode 100644
index 00000000..8856ec24
--- /dev/null
+++ b/SRC/clatrd.f
@@ -0,0 +1,279 @@
+      SUBROUTINE CLATRD( 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 ..
+      REAL               E( * )
+      COMPLEX            A( LDA, * ), TAU( * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLATRD 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', CLATRD reduces the last NB rows and columns of a
+*  matrix, of which the upper triangle is supplied;
+*  if UPLO = 'L', CLATRD reduces the first NB rows and columns of a
+*  matrix, of which the lower triangle is supplied.
+*
+*  This is an auxiliary routine called by CHETRD.
+*
+*  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 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) REAL 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 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 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            ZERO, ONE, HALF
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   HALF = ( 0.5E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IW
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CGEMV, CHEMV, CLACGV, CLARFG, CSCAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN, REAL
+*     ..
+*     .. 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 ) = REAL( A( I, I ) )
+               CALL CLACGV( N-I, W( I, IW+1 ), LDW )
+               CALL CGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
+               CALL CLACGV( N-I, W( I, IW+1 ), LDW )
+               CALL CLACGV( N-I, A( I, I+1 ), LDA )
+               CALL CGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
+     $                     LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
+               CALL CLACGV( N-I, A( I, I+1 ), LDA )
+               A( I, I ) = REAL( 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 CLARFG( 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 CHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
+     $                     ZERO, W( 1, IW ), 1 )
+               IF( I.LT.N ) THEN
+                  CALL CGEMV( 'Conjugate transpose', I-1, N-I, ONE,
+     $                        W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
+     $                        W( I+1, IW ), 1 )
+                  CALL CGEMV( 'No transpose', I-1, N-I, -ONE,
+     $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
+     $                        W( 1, IW ), 1 )
+                  CALL CGEMV( 'Conjugate transpose', I-1, N-I, ONE,
+     $                        A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
+     $                        W( I+1, IW ), 1 )
+                  CALL CGEMV( '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 CSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
+               ALPHA = -HALF*TAU( I-1 )*CDOTC( I-1, W( 1, IW ), 1,
+     $                 A( 1, I ), 1 )
+               CALL CAXPY( 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 ) = REAL( A( I, I ) )
+            CALL CLACGV( I-1, W( I, 1 ), LDW )
+            CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
+            CALL CLACGV( I-1, W( I, 1 ), LDW )
+            CALL CLACGV( I-1, A( I, 1 ), LDA )
+            CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
+     $                  LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
+            CALL CLACGV( I-1, A( I, 1 ), LDA )
+            A( I, I ) = REAL( 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 CLARFG( 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 CHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE,
+     $                     W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
+     $                     W( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE,
+     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
+     $                     W( 1, I ), 1 )
+               CALL CGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
+     $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL CSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
+               ALPHA = -HALF*TAU( I )*CDOTC( N-I, W( I+1, I ), 1,
+     $                 A( I+1, I ), 1 )
+               CALL CAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
+            END IF
+*
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CLATRD
+*
+      END
diff --git a/SRC/clatrs.f b/SRC/clatrs.f
new file mode 100644
index 00000000..2a32eabe
--- /dev/null
+++ b/SRC/clatrs.f
@@ -0,0 +1,879 @@
+      SUBROUTINE CLATRS( 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
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               CNORM( * )
+      COMPLEX            A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLATRS 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
+*  CTRSV 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 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 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) REAL
+*          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) REAL 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, CTRSV
+*  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 CTRSV 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 CTRSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0,
+     $                   TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
+      REAL               BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
+     $                   XBND, XJ, XMAX
+      COMPLEX            CSUMJ, TJJS, USCAL, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX, ISAMAX
+      REAL               SCASUM, SLAMCH
+      COMPLEX            CDOTC, CDOTU, CLADIV
+      EXTERNAL           LSAME, ICAMAX, ISAMAX, SCASUM, SLAMCH, CDOTC,
+     $                   CDOTU, CLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CSSCAL, CTRSV, SLABAD, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1, CABS2
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+      CABS2( ZDUM ) = ABS( REAL( ZDUM ) / 2. ) +
+     $                ABS( AIMAG( ZDUM ) / 2. )
+*     ..
+*     .. 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( 'CLATRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = SLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM / SLAMCH( '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 ) = SCASUM( J-1, A( 1, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N - 1
+               CNORM( J ) = SCASUM( 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 = ISAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM*HALF ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = HALF / ( SMLNUM*TMAX )
+         CALL SSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine CTRSV 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 CTRSV( 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 CSSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         ELSE
+            XMAX = XMAX*TWO
+         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 = CABS1( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = A( J, J )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 105
+               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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = CLADIV( 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
+  105          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 CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL CSSCAL( 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 CAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
+     $                           1 )
+                     I = ICAMAX( 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 CAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + ICAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+               END IF
+  110       CONTINUE
+*
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Solve A**T * x = b
+*
+            DO 150 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 = CLADIV( USCAL, TJJS )
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.CMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call CDOTU to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     CSUMJ = CDOTU( J-1, A( 1, J ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = CDOTU( 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
+                        CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
+  120                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 130 I = J + 1, N
+                        CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
+  130                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.CMPLX( 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 145
+                  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 CSSCAL( N, REC, X, 1 )
+                              SCALE = SCALE*REC
+                              XMAX = XMAX*REC
+                           END IF
+                        END IF
+                        X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                        X( J ) = CLADIV( X( J ), TJJS )
+                     ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0 and compute a solution to A**T *x = 0.
+*
+                        DO 140 I = 1, N
+                           X( I ) = ZERO
+  140                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  145             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 ) = CLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+  150       CONTINUE
+*
+         ELSE
+*
+*           Solve A**H * x = b
+*
+            DO 190 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 = CONJG( 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 = CLADIV( USCAL, TJJS )
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL CSSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.CMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call CDOTC to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     CSUMJ = CDOTC( J-1, A( 1, J ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = CDOTC( 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 160 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( CONJG( A( I, J ) )*USCAL )*
+     $                          X( I )
+  160                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 170 I = J + 1, N
+                        CSUMJ = CSUMJ + ( CONJG( A( I, J ) )*USCAL )*
+     $                          X( I )
+  170                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.CMPLX( 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 = CONJG( A( J, J ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 185
+                  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 CSSCAL( N, REC, X, 1 )
+                              SCALE = SCALE*REC
+                              XMAX = XMAX*REC
+                           END IF
+                        END IF
+                        X( J ) = CLADIV( 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 CSSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                        X( J ) = CLADIV( 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 180 I = 1, N
+                           X( I ) = ZERO
+  180                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  185             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 ) = CLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+  190       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of CLATRS
+*
+      END
diff --git a/SRC/clatrz.f b/SRC/clatrz.f
new file mode 100644
index 00000000..829fa63b
--- /dev/null
+++ b/SRC/clatrz.f
@@ -0,0 +1,133 @@
+      SUBROUTINE CLATRZ( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLATRZ 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 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 array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX            ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARFG, CLARZ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. 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 CLACGV( L, A( I, N-L+1 ), LDA )
+         ALPHA = CONJG( A( I, I ) )
+         CALL CLARFG( L+1, ALPHA, A( I, N-L+1 ), LDA, TAU( I ) )
+         TAU( I ) = CONJG( TAU( I ) )
+*
+*        Apply H(i) to A(1:i-1,i:n) from the right
+*
+         CALL CLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
+     $               CONJG( TAU( I ) ), A( 1, I ), LDA, WORK )
+         A( I, I ) = CONJG( ALPHA )
+*
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of CLATRZ
+*
+      END
diff --git a/SRC/clatzm.f b/SRC/clatzm.f
new file mode 100644
index 00000000..da8c1990
--- /dev/null
+++ b/SRC/clatzm.f
@@ -0,0 +1,146 @@
+      SUBROUTINE CLATZM( 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
+      COMPLEX            TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine CUNMRZ.
+*
+*  CLATZM applies a Householder matrix generated by CTZRQF 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) COMPLEX 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) COMPLEX
+*          The value tau in the representation of P.
+*
+*  C1      (input/output) COMPLEX 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) COMPLEX 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 >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX array, dimension
+*                      (N) if SIDE = 'L'
+*                      (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMV, CGERC, CGERU, CLACGV
+*     ..
+*     .. 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 :=  conjg( C1 + v' * C2 )
+*
+         CALL CCOPY( N, C1, LDC, WORK, 1 )
+         CALL CLACGV( N, WORK, 1 )
+         CALL CGEMV( 'Conjugate transpose', M-1, N, ONE, C2, LDC, V,
+     $               INCV, ONE, WORK, 1 )
+*
+*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
+*        [ C2 ]    [ C2 ]        [ v ]
+*
+         CALL CLACGV( N, WORK, 1 )
+         CALL CAXPY( N, -TAU, WORK, 1, C1, LDC )
+         CALL CGERU( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
+*
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        w := C1 + C2 * v
+*
+         CALL CCOPY( M, C1, 1, WORK, 1 )
+         CALL CGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
+     $               WORK, 1 )
+*
+*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
+*
+         CALL CAXPY( M, -TAU, WORK, 1, C1, 1 )
+         CALL CGERC( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
+      END IF
+*
+      RETURN
+*
+*     End of CLATZM
+*
+      END
diff --git a/SRC/clauu2.f b/SRC/clauu2.f
new file mode 100644
index 00000000..50c66a78
--- /dev/null
+++ b/SRC/clauu2.f
@@ -0,0 +1,143 @@
+      SUBROUTINE CLAUU2( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAUU2 computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the unblocked form of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CLACGV, CSSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX, MAX, REAL
+*     ..
+*     .. 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( 'CLAUU2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the product U * U'.
+*
+         DO 10 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = AII*AII + REAL( CDOTC( N-I, A( I, I+1 ), LDA,
+     $                     A( I, I+1 ), LDA ) )
+               CALL CLACGV( N-I, A( I, I+1 ), LDA )
+               CALL CGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, CMPLX( AII ),
+     $                     A( 1, I ), 1 )
+               CALL CLACGV( N-I, A( I, I+1 ), LDA )
+            ELSE
+               CALL CSSCAL( I, AII, A( 1, I ), 1 )
+            END IF
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product L' * L.
+*
+         DO 20 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = AII*AII + REAL( CDOTC( N-I, A( I+1, I ), 1,
+     $                     A( I+1, I ), 1 ) )
+               CALL CLACGV( I-1, A( I, 1 ), LDA )
+               CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE,
+     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1,
+     $                     CMPLX( AII ), A( I, 1 ), LDA )
+               CALL CLACGV( I-1, A( I, 1 ), LDA )
+            ELSE
+               CALL CSSCAL( I, AII, A( I, 1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CLAUU2
+*
+      END
diff --git a/SRC/clauum.f b/SRC/clauum.f
new file mode 100644
index 00000000..9bc3a995
--- /dev/null
+++ b/SRC/clauum.f
@@ -0,0 +1,160 @@
+      SUBROUTINE CLAUUM( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CLAUUM computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the blocked form of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CHERK, CLAUU2, CTRMM, 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( 'CLAUUM', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'CLAUUM', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL CLAUU2( UPLO, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( UPPER ) THEN
+*
+*           Compute the product U * U'.
+*
+            DO 10 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Non-unit', I-1, IB, CONE, A( I, I ), LDA,
+     $                     A( 1, I ), LDA )
+               CALL CLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL CGEMM( 'No transpose', 'Conjugate transpose',
+     $                        I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ),
+     $                        LDA, A( I, I+IB ), LDA, CONE, A( 1, I ),
+     $                        LDA )
+                  CALL CHERK( 'Upper', 'No transpose', IB, N-I-IB+1,
+     $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
+     $                        LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute the product L' * L.
+*
+            DO 20 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL CTRMM( 'Left', 'Lower', 'Conjugate transpose',
+     $                     'Non-unit', IB, I-1, CONE, A( I, I ), LDA,
+     $                     A( I, 1 ), LDA )
+               CALL CLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL CGEMM( 'Conjugate transpose', 'No transpose', IB,
+     $                        I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA,
+     $                        A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA )
+                  CALL CHERK( 'Lower', 'Conjugate transpose', IB,
+     $                        N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE,
+     $                        A( I, I ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CLAUUM
+*
+      END
diff --git a/SRC/cpbcon.f b/SRC/cpbcon.f
new file mode 100644
index 00000000..cbe86980
--- /dev/null
+++ b/SRC/cpbcon.f
@@ -0,0 +1,198 @@
+      SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, 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 CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite band matrix using
+*  the Cholesky factorization A = U**H*U or A = L*L**H computed by
+*  CPBTRF.
+*
+*  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 triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  ANORM   (input) REAL
+*          The 1-norm (or infinity-norm) of the Hermitian band matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      REAL               AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATBS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL CLATBS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, KD, AB, LDAB, WORK, SCALEL, RWORK,
+     $                   INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL CLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEU, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL CLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL CLATBS( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, KD, AB, LDAB, WORK, SCALEU, RWORK,
+     $                   INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = ICAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL CSRSCL( 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 CPBCON
+*
+      END
diff --git a/SRC/cpbequ.f b/SRC/cpbequ.f
new file mode 100644
index 00000000..07beb1b8
--- /dev/null
+++ b/SRC/cpbequ.f
@@ -0,0 +1,167 @@
+      SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBEQU computes row and column scalings intended to equilibrate a
+*  Hermitian positive definite band matrix A and reduce its condition
+*  number (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular of A is stored;
+*          = 'L':  Lower triangular of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangle of the Hermitian band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB     (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  S       (output) REAL array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) REAL
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  AMAX    (output) REAL
+*          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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, J
+      REAL               SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+         J = KD + 1
+      ELSE
+         J = 1
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = REAL( AB( J, 1 ) )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      DO 10 I = 2, N
+         S( I ) = REAL( AB( J, I ) )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of CPBEQU
+*
+      END
diff --git a/SRC/cpbrfs.f b/SRC/cpbrfs.f
new file mode 100644
index 00000000..b220be36
--- /dev/null
+++ b/SRC/cpbrfs.f
@@ -0,0 +1,346 @@
+      SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
+     $                   LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite
+*  and banded, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangle of the Hermitian band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  AFB     (input) COMPLEX array, dimension (LDAFB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H of the band matrix A as computed by
+*          CPBTRF, in the same storage format as A (see AB).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CPBTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, L, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CHBMV, CLACN2, CPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( N+1, 2*KD+2 )
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CHBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
+     $               WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               L = KD + 1 - K
+               DO 40 I = MAX( 1, K-KD ), K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AB( L+I, K ) )*XK
+                  S = S + CABS1( AB( L+I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( REAL( AB( KD+1, K ) ) )*
+     $                      XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( REAL( AB( 1, K ) ) )*XK
+               L = 1 - K
+               DO 60 I = K + 1, MIN( N, K+KD )
+                  RWORK( I ) = RWORK( I ) + CABS1( AB( L+I, K ) )*XK
+                  S = S + CABS1( AB( L+I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CPBRFS
+*
+      END
diff --git a/SRC/cpbstf.f b/SRC/cpbstf.f
new file mode 100644
index 00000000..619f4693
--- /dev/null
+++ b/SRC/cpbstf.f
@@ -0,0 +1,263 @@
+      SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBSTF computes a split Cholesky factorization of a complex
+*  Hermitian positive definite band matrix A.
+*
+*  This routine is designed to be used in conjunction with CHBGST.
+*
+*  The factorization has the form  A = S**H*S  where S is a band matrix
+*  of the same bandwidth as A and the following structure:
+*
+*    S = ( U    )
+*        ( M  L )
+*
+*  where U is upper triangular of order m = (n+kd)/2, and L is lower
+*  triangular of order n-m.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first kd+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the factor S from the split Cholesky
+*          factorization A = S**H*S. See Further Details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, the factorization could not be completed,
+*               because the updated element a(i,i) was negative; the
+*               matrix A is not positive definite.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 7, KD = 2:
+*
+*  S = ( s11  s12  s13                     )
+*      (      s22  s23  s24                )
+*      (           s33  s34                )
+*      (                s44                )
+*      (           s53  s54  s55           )
+*      (                s64  s65  s66      )
+*      (                     s75  s76  s77 )
+*
+*  If UPLO = 'U', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53' s64' s75'
+*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54' s65' s76'
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*
+*  If UPLO = 'L', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*  a21  a32  a43  a54  a65  a76   *   s12' s23' s34' s54  s65  s76   *
+*  a31  a42  a53  a64  a64   *    *   s13' s24' s53  s64  s75   *    *
+*
+*  Array elements marked * are not used by the routine; s12' denotes
+*  conjg(s12); the diagonal elements of S are real.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KM, M
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHER, CLACGV, CSSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBSTF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+*     Set the splitting point m.
+*
+      M = ( N+KD ) / 2
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
+*
+         DO 10 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = REAL( AB( KD+1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( KD+1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th column and update the
+*           the leading submatrix within the band.
+*
+            CALL CSSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
+            CALL CHER( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
+     $                 AB( KD+1, J-KM ), KLD )
+   10    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**H*U.
+*
+         DO 20 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = REAL( AB( KD+1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( KD+1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL CSSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL CLACGV( KM, AB( KD, J+1 ), KLD )
+               CALL CHER( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+               CALL CLACGV( KM, AB( KD, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
+*
+         DO 30 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = REAL( AB( 1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( 1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            CALL CSSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
+            CALL CLACGV( KM, AB( KM+1, J-KM ), KLD )
+            CALL CHER( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
+     $                 AB( 1, J-KM ), KLD )
+            CALL CLACGV( KM, AB( KM+1, J-KM ), KLD )
+   30    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**H*U.
+*
+         DO 40 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = REAL( AB( 1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( 1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th column and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL CSSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
+               CALL CHER( 'Lower', KM, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+   50 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of CPBSTF
+*
+      END
diff --git a/SRC/cpbsv.f b/SRC/cpbsv.f
new file mode 100644
index 00000000..4a7f62f8
--- /dev/null
+++ b/SRC/cpbsv.f
@@ -0,0 +1,151 @@
+      SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**H * U,  if UPLO = 'U', or
+*     A = L * L**H,  if UPLO = 'L',
+*  where U is an upper triangular band matrix, and L is a lower
+*  triangular band matrix, with the same number of superdiagonals or
+*  subdiagonals as A.  The factored form of A is then used to solve the
+*  system of equations A * X = B.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**H*U or A = L*L**H of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) COMPLEX 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CPBTRF, CPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL CPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of CPBSV
+*
+      END
diff --git a/SRC/cpbsvx.f b/SRC/cpbsvx.f
new file mode 100644
index 00000000..90d25538
--- /dev/null
+++ b/SRC/cpbsvx.f
@@ -0,0 +1,421 @@
+      SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * ), S( * )
+      COMPLEX            AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
+*  compute the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**H * U,  if UPLO = 'U', or
+*        A = L * L**H,  if UPLO = 'L',
+*     where U is an upper triangular band matrix, and L is a lower
+*     triangular band matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFB contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AB and AFB will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right-hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array, except
+*          if FACT = 'F' and EQUED = 'Y', then A must contain the
+*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A
+*          is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  AFB     (input or output) COMPLEX array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the band matrix
+*          A, in the same storage format as A (see AB).  If EQUED = 'Y',
+*          then AFB is the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the equilibrated
+*          matrix A (see the description of A for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) REAL array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          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) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11  a12  a13
+*          a22  a23  a24
+*               a33  a34  a35
+*                    a44  a45  a46
+*                         a55  a56
+*     (aij=conjg(aji))         a66
+*
+*  Band storage of the upper triangle of A:
+*
+*      *    *   a13  a24  a35  a46
+*      *   a12  a23  a34  a45  a56
+*     a11  a22  a33  a44  a55  a66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*     a11  a22  a33  a44  a55  a66
+*     a21  a32  a43  a54  a65   *
+*     a31  a42  a53  a64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU, UPPER
+      INTEGER            I, INFEQU, J, J1, J2
+      REAL               AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHB, SLAMCH
+      EXTERNAL           LSAME, CLANHB, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CLAQHB, CPBCON, CPBEQU, CPBRFS,
+     $                   CPBTRF, CPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -9
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -10
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -11
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -13
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -15
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         IF( UPPER ) THEN
+            DO 40 J = 1, N
+               J1 = MAX( J-KD, 1 )
+               CALL CCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
+     $                     AFB( KD+1-J+J1, J ), 1 )
+   40       CONTINUE
+         ELSE
+            DO 50 J = 1, N
+               J2 = MIN( J+KD, N )
+               CALL CCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
+   50       CONTINUE
+         END IF
+*
+         CALL CPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANHB( '1', UPLO, N, KD, AB, LDAB, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, RWORK,
+     $             INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 70 J = 1, NRHS
+            DO 60 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   60       CONTINUE
+   70    CONTINUE
+         DO 80 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   80    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CPBSVX
+*
+      END
diff --git a/SRC/cpbtf2.f b/SRC/cpbtf2.f
new file mode 100644
index 00000000..4049b90e
--- /dev/null
+++ b/SRC/cpbtf2.f
@@ -0,0 +1,200 @@
+      SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBTF2 computes the Cholesky factorization of a complex Hermitian
+*  positive definite band 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, U' is the conjugate transpose
+*  of U, 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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KN
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHER, CLACGV, CSSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         DO 10 J = 1, N
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = REAL( AB( KD+1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( KD+1, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of row J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL CSSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL CLACGV( KN, AB( KD, J+1 ), KLD )
+               CALL CHER( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+               CALL CLACGV( KN, AB( KD, J+1 ), KLD )
+            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 = REAL( AB( 1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( 1, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of column J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL CSSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
+               CALL CHER( 'Lower', KN, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+   30 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of CPBTF2
+*
+      END
diff --git a/SRC/cpbtrf.f b/SRC/cpbtrf.f
new file mode 100644
index 00000000..cee79d69
--- /dev/null
+++ b/SRC/cpbtrf.f
@@ -0,0 +1,371 @@
+      SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBTRF computes the Cholesky factorization of a complex Hermitian
+*  positive definite band 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.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**H*U or A = L*L**H of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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 band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  Contributed by
+*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, IB, II, J, JJ, NB
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            WORK( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CHERK, CPBTF2, CPOTF2, CTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
+     $    ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment
+*
+      NB = ILAENV( 1, 'CPBTRF', UPLO, N, KD, -1, -1 )
+*
+*     The block size must not exceed the semi-bandwidth KD, and must not
+*     exceed the limit set by the size of the local array WORK.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KD ) THEN
+*
+*        Use unblocked code
+*
+         CALL CPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Compute the Cholesky factorization of a Hermitian band
+*           matrix, given the upper triangle of the matrix in band
+*           storage.
+*
+*           Zero the upper triangle of the work array.
+*
+            DO 20 J = 1, NB
+               DO 10 I = 1, J - 1
+                  WORK( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 70 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL CPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11   A12   A13
+*                          A22   A23
+*                                A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A12, A22 and
+*                 A23 are empty if IB = KD. The upper triangle of A13
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A12
+*
+                     CALL CTRSM( 'Left', 'Upper', 'Conjugate transpose',
+     $                           'Non-unit', IB, I2, CONE,
+     $                           AB( KD+1, I ), LDAB-1,
+     $                           AB( KD+1-IB, I+IB ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL CHERK( 'Upper', 'Conjugate transpose', I2, IB,
+     $                           -ONE, AB( KD+1-IB, I+IB ), LDAB-1, ONE,
+     $                           AB( KD+1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the lower triangle of A13 into the work array.
+*
+                     DO 40 JJ = 1, I3
+                        DO 30 II = JJ, IB
+                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
+   30                   CONTINUE
+   40                CONTINUE
+*
+*                    Update A13 (in the work array).
+*
+                     CALL CTRSM( 'Left', 'Upper', 'Conjugate transpose',
+     $                           'Non-unit', IB, I3, CONE,
+     $                           AB( KD+1, I ), LDAB-1, WORK, LDWORK )
+*
+*                    Update A23
+*
+                     IF( I2.GT.0 )
+     $                  CALL CGEMM( 'Conjugate transpose',
+     $                              'No transpose', I2, I3, IB, -CONE,
+     $                              AB( KD+1-IB, I+IB ), LDAB-1, WORK,
+     $                              LDWORK, CONE, AB( 1+IB, I+KD ),
+     $                              LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL CHERK( 'Upper', 'Conjugate transpose', I3, IB,
+     $                           -ONE, WORK, LDWORK, ONE,
+     $                           AB( KD+1, I+KD ), LDAB-1 )
+*
+*                    Copy the lower triangle of A13 back into place.
+*
+                     DO 60 JJ = 1, I3
+                        DO 50 II = JJ, IB
+                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
+   50                   CONTINUE
+   60                CONTINUE
+                  END IF
+               END IF
+   70       CONTINUE
+         ELSE
+*
+*           Compute the Cholesky factorization of a Hermitian band
+*           matrix, given the lower triangle of the matrix in band
+*           storage.
+*
+*           Zero the lower triangle of the work array.
+*
+            DO 90 J = 1, NB
+               DO 80 I = J + 1, NB
+                  WORK( I, J ) = ZERO
+   80          CONTINUE
+   90       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 140 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL CPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11
+*                    A21   A22
+*                    A31   A32   A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A21, A22 and
+*                 A32 are empty if IB = KD. The lower triangle of A31
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A21
+*
+                     CALL CTRSM( 'Right', 'Lower',
+     $                           'Conjugate transpose', 'Non-unit', I2,
+     $                           IB, CONE, AB( 1, I ), LDAB-1,
+     $                           AB( 1+IB, I ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL CHERK( 'Lower', 'No transpose', I2, IB, -ONE,
+     $                           AB( 1+IB, I ), LDAB-1, ONE,
+     $                           AB( 1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the upper triangle of A31 into the work array.
+*
+                     DO 110 JJ = 1, IB
+                        DO 100 II = 1, MIN( JJ, I3 )
+                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
+  100                   CONTINUE
+  110                CONTINUE
+*
+*                    Update A31 (in the work array).
+*
+                     CALL CTRSM( 'Right', 'Lower',
+     $                           'Conjugate transpose', 'Non-unit', I3,
+     $                           IB, CONE, AB( 1, I ), LDAB-1, WORK,
+     $                           LDWORK )
+*
+*                    Update A32
+*
+                     IF( I2.GT.0 )
+     $                  CALL CGEMM( 'No transpose',
+     $                              'Conjugate transpose', I3, I2, IB,
+     $                              -CONE, WORK, LDWORK, AB( 1+IB, I ),
+     $                              LDAB-1, CONE, AB( 1+KD-IB, I+IB ),
+     $                              LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL CHERK( 'Lower', 'No transpose', I3, IB, -ONE,
+     $                           WORK, LDWORK, ONE, AB( 1, I+KD ),
+     $                           LDAB-1 )
+*
+*                    Copy the upper triangle of A31 back into place.
+*
+                     DO 130 JJ = 1, IB
+                        DO 120 II = 1, MIN( JJ, I3 )
+                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
+  120                   CONTINUE
+  130                CONTINUE
+                  END IF
+               END IF
+  140       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+  150 CONTINUE
+      RETURN
+*
+*     End of CPBTRF
+*
+      END
diff --git a/SRC/cpbtrs.f b/SRC/cpbtrs.f
new file mode 100644
index 00000000..ca66fd1e
--- /dev/null
+++ b/SRC/cpbtrs.f
@@ -0,0 +1,145 @@
+      SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPBTRS solves a system of linear equations A*X = B with a Hermitian
+*  positive definite band matrix A using the Cholesky factorization
+*  A = U**H*U or A = L*L**H computed by CPBTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) COMPLEX 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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPBTRS', -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.
+*
+         DO 10 J = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
+     $                  KD, AB, LDAB, B( 1, J ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 J = 1, NRHS
+*
+*           Solve L*X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+*
+*           Solve L'*X = B, overwriting B with X.
+*
+            CALL CTBSV( 'Lower', 'Conjugate transpose', 'Non-unit', N,
+     $                  KD, AB, LDAB, B( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CPBTRS
+*
+      END
diff --git a/SRC/cpocon.f b/SRC/cpocon.f
new file mode 100644
index 00000000..d4b4c44b
--- /dev/null
+++ b/SRC/cpocon.f
@@ -0,0 +1,184 @@
+      SUBROUTINE CPOCON( UPLO, 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 CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite matrix using the
+*  Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by CPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) REAL
+*          The 1-norm (or infinity-norm) of the Hermitian matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      REAL               AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATRS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CPOCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of inv(A).
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL CLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, A, LDA, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL CLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEU, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL CLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL CLATRS( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, A, LDA, WORK, SCALEU, RWORK, INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = ICAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL CSRSCL( 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 CPOCON
+*
+      END
diff --git a/SRC/cpoequ.f b/SRC/cpoequ.f
new file mode 100644
index 00000000..f08acd3e
--- /dev/null
+++ b/SRC/cpoequ.f
@@ -0,0 +1,137 @@
+      SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOEQU computes row and column scalings intended to equilibrate a
+*  Hermitian positive definite matrix A and reduce its condition number
+*  (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX array, dimension (LDA,N)
+*          The N-by-N Hermitian positive definite matrix whose scaling
+*          factors are to be computed.  Only the diagonal elements of A
+*          are referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  S       (output) REAL array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) REAL
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  AMAX    (output) REAL
+*          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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               SMIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPOEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      S( 1 ) = REAL( A( 1, 1 ) )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+      DO 10 I = 2, N
+         S( I ) = REAL( A( I, I ) )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of CPOEQU
+*
+      END
diff --git a/SRC/cporfs.f b/SRC/cporfs.f
new file mode 100644
index 00000000..49001285
--- /dev/null
+++ b/SRC/cporfs.f
@@ -0,0 +1,337 @@
+      SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
+     $                   LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPORFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite,
+*  and provides error bounds and backward error estimates for the
+*  solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX 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.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input) COMPLEX array, dimension (LDAF,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by CPOTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CPOTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CHEMV, CLACN2, CPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPORFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CHEMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( REAL( A( K, K ) ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( REAL( A( K, K ) ) )*XK
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CPORFS
+*
+      END
diff --git a/SRC/cposv.f b/SRC/cposv.f
new file mode 100644
index 00000000..8e57d3f0
--- /dev/null
+++ b/SRC/cposv.f
@@ -0,0 +1,121 @@
+      SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, 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, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     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 a lower triangular
+*  matrix.  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) COMPLEX 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).
+*
+*  B       (input/output) COMPLEX 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CPOTRF, CPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPOSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL CPOTRF( UPLO, N, A, LDA, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of CPOSV
+*
+      END
diff --git a/SRC/cposvx.f b/SRC/cposvx.f
new file mode 100644
index 00000000..af37ec8d
--- /dev/null
+++ b/SRC/cposvx.f
@@ -0,0 +1,376 @@
+      SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
+     $                   S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
+     $                   RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * ), S( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
+*  compute the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite 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:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**H* U,  if UPLO = 'U', or
+*        A = L * L**H,  if UPLO = 'L',
+*     where U is an upper triangular matrix and L is a lower triangular
+*     matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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 contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  A and AF will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A, except if FACT = 'F' and
+*          EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input or output) COMPLEX array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, in the same storage
+*          format as A.  If EQUED .ne. 'N', then AF is the factored form
+*          of the equilibrated matrix diag(S)*A*diag(S).
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the original
+*          matrix A.
+*
+*          If FACT = 'E', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H 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).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) REAL array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS righthand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          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) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      REAL               AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHE, SLAMCH
+      EXTERNAL           LSAME, CLANHE, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACPY, CLAQHE, CPOCON, CPOEQU, CPORFS, CPOTRF,
+     $                   CPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -9
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -10
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -14
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPOSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL CPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL CLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL CPOTRF( UPLO, N, AF, LDAF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
+     $             FERR, BERR, WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CPOSVX
+*
+      END
diff --git a/SRC/cpotf2.f b/SRC/cpotf2.f
new file mode 100644
index 00000000..8edd89a3
--- /dev/null
+++ b/SRC/cpotf2.f
@@ -0,0 +1,174 @@
+      SUBROUTINE CPOTF2( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOTF2 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 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CLACGV, CSSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, REAL, 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( 'CPOTF2', -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 = REAL( A( J, J ) ) - CDOTC( 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 CLACGV( J-1, A( 1, J ), 1 )
+               CALL CGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ),
+     $                     LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA )
+               CALL CLACGV( J-1, A( 1, J ), 1 )
+               CALL CSSCAL( 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 = REAL( A( J, J ) ) - CDOTC( 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 CLACGV( J-1, A( J, 1 ), LDA )
+               CALL CGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ),
+     $                     LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 )
+               CALL CLACGV( J-1, A( J, 1 ), LDA )
+               CALL CSSCAL( 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 CPOTF2
+*
+      END
diff --git a/SRC/cpotrf.f b/SRC/cpotrf.f
new file mode 100644
index 00000000..f6965275
--- /dev/null
+++ b/SRC/cpotrf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE CPOTRF( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOTRF 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 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 ..
+      REAL               ONE
+      COMPLEX            CONE
+      PARAMETER          ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CHERK, CPOTF2, CTRSM, 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( 'CPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'CPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL CPOTF2( 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 CHERK( 'Upper', 'Conjugate transpose', JB, J-1,
+     $                     -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
+               CALL CPOTF2( '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 CGEMM( '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 CTRSM( '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 CHERK( 'Lower', 'No transpose', JB, J-1, -ONE,
+     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
+               CALL CPOTF2( '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 CGEMM( '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 CTRSM( '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 CPOTRF
+*
+      END
diff --git a/SRC/cpotri.f b/SRC/cpotri.f
new file mode 100644
index 00000000..de48482f
--- /dev/null
+++ b/SRC/cpotri.f
@@ -0,0 +1,96 @@
+      SUBROUTINE CPOTRI( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOTRI computes the inverse of a complex Hermitian positive definite
+*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
+*  computed by CPOTRF.
+*
+*  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 array, dimension (LDA,N)
+*          On entry, the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, as computed by
+*          CPOTRF.
+*          On exit, the upper or lower triangle of the (Hermitian)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  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 (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLAUUM, CTRTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPOTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL CTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+*     Form inv(U)*inv(U)' or inv(L)'*inv(L).
+*
+      CALL CLAUUM( UPLO, N, A, LDA, INFO )
+*
+      RETURN
+*
+*     End of CPOTRI
+*
+      END
diff --git a/SRC/cpotrs.f b/SRC/cpotrs.f
new file mode 100644
index 00000000..3bfe1264
--- /dev/null
+++ b/SRC/cpotrs.f
@@ -0,0 +1,132 @@
+      SUBROUTINE CPOTRS( 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 ..
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPOTRS solves a system of linear equations A*X = B with a Hermitian
+*  positive definite matrix A using the Cholesky factorization 
+*  A = U**H*U or A = L*L**H computed by CPOTRF.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by CPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTRSM, 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( 'CPOTRS', -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 CTRSM( 'Left', 'Upper', 'Conjugate transpose', 'Non-unit',
+     $               N, NRHS, ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL CTRSM( '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 CTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL CTRSM( 'Left', 'Lower', 'Conjugate transpose', 'Non-unit',
+     $               N, NRHS, ONE, A, LDA, B, LDB )
+      END IF
+*
+      RETURN
+*
+*     End of CPOTRS
+*
+      END
diff --git a/SRC/cppcon.f b/SRC/cppcon.f
new file mode 100644
index 00000000..b7891424
--- /dev/null
+++ b/SRC/cppcon.f
@@ -0,0 +1,183 @@
+      SUBROUTINE CPPCON( UPLO, N, AP, 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 CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPCON estimates the reciprocal of the condition number (in the 
+*  1-norm) of a complex Hermitian positive definite packed matrix using
+*  the Cholesky factorization A = U**H*U or A = L*L**H computed by
+*  CPPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  ANORM   (input) REAL
+*          The 1-norm (or infinity-norm) of the Hermitian matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      REAL               AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATPS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPPCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL CLATPS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, AP, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL CLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEU, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL CLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL CLATPS( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, AP, WORK, SCALEU, RWORK, INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = ICAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL CSRSCL( 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 CPPCON
+*
+      END
diff --git a/SRC/cppequ.f b/SRC/cppequ.f
new file mode 100644
index 00000000..369e1232
--- /dev/null
+++ b/SRC/cppequ.f
@@ -0,0 +1,169 @@
+      SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, 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
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               S( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPEQU computes row and column scalings intended to equilibrate a
+*  Hermitian positive definite matrix A in packed storage and reduce
+*  its condition number (with respect to the two-norm).  S contains the
+*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
+*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
+*  This choice of S puts the condition number of B within a factor N of
+*  the smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  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) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian 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.
+*
+*  S       (output) REAL array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) REAL
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  AMAX    (output) REAL
+*          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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, JJ
+      REAL               SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL, 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( 'CPPEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = REAL( AP( 1 ) )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+      IF( UPPER ) THEN
+*
+*        UPLO = 'U':  Upper triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 10 I = 2, N
+            JJ = JJ + I
+            S( I ) = REAL( AP( JJ ) )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   10    CONTINUE
+*
+      ELSE
+*
+*        UPLO = 'L':  Lower triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 20 I = 2, N
+            JJ = JJ + N - I + 2
+            S( I ) = REAL( AP( JJ ) )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   20    CONTINUE
+      END IF
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 30 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   30    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 40 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   40    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of CPPEQU
+*
+      END
diff --git a/SRC/cpprfs.f b/SRC/cpprfs.f
new file mode 100644
index 00000000..b9e84355
--- /dev/null
+++ b/SRC/cpprfs.f
@@ -0,0 +1,335 @@
+      SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
+     $                   BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian 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.
+*
+*  AFP     (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF,
+*          packed columnwise in a linear array in the same format as A
+*          (see AP).
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CPPTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CHPMV, CLACN2, CPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CHPMV( UPLO, N, -CONE, AP, X( 1, J ), 1, CONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( REAL( AP( KK+K-1 ) ) )*
+     $                      XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( REAL( AP( KK ) ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
+            CALL CAXPY( N, CONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CPPRFS
+*
+      END
diff --git a/SRC/cppsv.f b/SRC/cppsv.f
new file mode 100644
index 00000000..078d4c97
--- /dev/null
+++ b/SRC/cppsv.f
@@ -0,0 +1,133 @@
+      SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**H* U,  if UPLO = 'U', or
+*     A = L * L**H,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is a lower triangular
+*  matrix.  The factored form of A is then used to solve the system of
+*  equations A * X = B.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.  
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, in the same storage
+*          format as A.
+*
+*  B       (input/output) COMPLEX 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CPPTRF, CPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL CPPTRF( UPLO, N, AP, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of CPPSV
+*
+      END
diff --git a/SRC/cppsvx.f b/SRC/cppsvx.f
new file mode 100644
index 00000000..1dec90c6
--- /dev/null
+++ b/SRC/cppsvx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
+     $                   X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * ), S( * )
+      COMPLEX            AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
+*  compute the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U'* U ,  if UPLO = 'U', or
+*        A = L * L',  if UPLO = 'L',
+*     where U is an upper triangular matrix, L is a lower triangular
+*     matrix, and ' indicates conjugate transpose.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFP contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AP and AFP will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array, except if FACT = 'F'
+*          and EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  The j-th column of A is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  AFP     (input or output) COMPLEX array, dimension (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, in the same storage
+*          format as A.  If EQUED .ne. 'N', then AFP is the factored
+*          form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the original
+*          matrix A.
+*
+*          If FACT = 'E', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the equilibrated
+*          matrix A (see the description of AP for the form of the
+*          equilibrated matrix).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) REAL array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          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) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      REAL               AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHP, SLAMCH
+      EXTERNAL           LSAME, CLANHP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CLAQHP, CPPCON, CPPEQU, CPPRFS,
+     $                   CPPTRF, CPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -7
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -8
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -10
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL CCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL CPPTRF( UPLO, N, AFP, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANHP( 'I', UPLO, N, AP, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
+     $             WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CPPSVX
+*
+      END
diff --git a/SRC/cpptrf.f b/SRC/cpptrf.f
new file mode 100644
index 00000000..48148e3e
--- /dev/null
+++ b/SRC/cpptrf.f
@@ -0,0 +1,178 @@
+      SUBROUTINE CPPTRF( 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 ..
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPTRF computes the Cholesky factorization of a complex Hermitian
+*  positive definite matrix A stored in packed format.
+*
+*  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.
+*
+*  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) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or A = L*L**H, 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 Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPR, CSSCAL, CTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL, 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( 'CPPTRF', -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 CTPSV( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                     J-1, AP, AP( JC ), 1 )
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = REAL( AP( JJ ) ) - CDOTC( 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 = REAL( 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 CSSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
+               CALL CHPR( '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 CPPTRF
+*
+      END
diff --git a/SRC/cpptri.f b/SRC/cpptri.f
new file mode 100644
index 00000000..257c3908
--- /dev/null
+++ b/SRC/cpptri.f
@@ -0,0 +1,130 @@
+      SUBROUTINE CPPTRI( 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 ..
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPTRI computes the inverse of a complex Hermitian positive definite
+*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
+*  computed by CPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor is stored in AP;
+*          = 'L':  Lower triangular factor is stored in AP.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, packed columnwise as
+*          a linear array.  The j-th column of U or L is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*          On exit, the upper or lower triangle of the (Hermitian)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ, JJN
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CHPR, CSSCAL, CTPMV, CTPTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL
+*     ..
+*     .. 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( 'CPPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL CTPTRI( UPLO, 'Non-unit', N, AP, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+      IF( UPPER ) THEN
+*
+*        Compute the product inv(U) * inv(U)'.
+*
+         JJ = 0
+         DO 10 J = 1, N
+            JC = JJ + 1
+            JJ = JJ + J
+            IF( J.GT.1 )
+     $         CALL CHPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
+            AJJ = AP( JJ )
+            CALL CSSCAL( J, AJJ, AP( JC ), 1 )
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product inv(L)' * inv(L).
+*
+         JJ = 1
+         DO 20 J = 1, N
+            JJN = JJ + N - J + 1
+            AP( JJ ) = REAL( CDOTC( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) )
+            IF( J.LT.N )
+     $         CALL CTPMV( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                     N-J, AP( JJN ), AP( JJ+1 ), 1 )
+            JJ = JJN
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CPPTRI
+*
+      END
diff --git a/SRC/cpptrs.f b/SRC/cpptrs.f
new file mode 100644
index 00000000..aa64389b
--- /dev/null
+++ b/SRC/cpptrs.f
@@ -0,0 +1,134 @@
+      SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPPTRS solves a system of linear equations A*X = B with a Hermitian
+*  positive definite matrix A in packed storage using the Cholesky
+*  factorization A = U**H*U or A = L*L**H computed by CPPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  B       (input/output) COMPLEX 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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPPTRS', -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.
+*
+         DO 10 I = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL CTPSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
+     $                  AP, B( 1, I ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL CTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve L*Y = B, overwriting B with X.
+*
+            CALL CTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+*
+*           Solve L'*X = Y, overwriting B with X.
+*
+            CALL CTPSV( 'Lower', 'Conjugate transpose', 'Non-unit', N,
+     $                  AP, B( 1, I ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CPPTRS
+*
+      END
diff --git a/SRC/cptcon.f b/SRC/cptcon.f
new file mode 100644
index 00000000..81979f86
--- /dev/null
+++ b/SRC/cptcon.f
@@ -0,0 +1,150 @@
+      SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), RWORK( * )
+      COMPLEX            E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTCON computes the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite tridiagonal matrix
+*  using the factorization A = L*D*L**H or A = U**H*D*U computed by
+*  CPTTRF.
+*
+*  Norm(inv(A)) is computed by a direct method, and the reciprocal of
+*  the condition number is computed as
+*                   RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization of A, as computed by CPTTRF.
+*
+*  E       (input) COMPLEX array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the unit bidiagonal factor
+*          U or L from the factorization of A, as computed by CPTTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
+*          1-norm of inv(A) computed in this routine.
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The method used is described in Nicholas J. Higham, "Efficient
+*  Algorithms for Computing the Condition Number of a Tridiagonal
+*  Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      REAL               AINVNM
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      EXTERNAL           ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is positive.
+*
+      DO 10 I = 1, N
+         IF( D( I ).LE.ZERO )
+     $      RETURN
+   10 CONTINUE
+*
+*     Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*        m(i,j) =  abs(A(i,j)), i = j,
+*        m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*     and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*     Solve M(L) * x = e.
+*
+      RWORK( 1 ) = ONE
+      DO 20 I = 2, N
+         RWORK( I ) = ONE + RWORK( I-1 )*ABS( E( I-1 ) )
+   20 CONTINUE
+*
+*     Solve D * M(L)' * x = b.
+*
+      RWORK( N ) = RWORK( N ) / D( N )
+      DO 30 I = N - 1, 1, -1
+         RWORK( I ) = RWORK( I ) / D( I ) + RWORK( I+1 )*ABS( E( I ) )
+   30 CONTINUE
+*
+*     Compute AINVNM = max(x(i)), 1<=i<=n.
+*
+      IX = ISAMAX( N, RWORK, 1 )
+      AINVNM = ABS( RWORK( IX ) )
+*
+*     Compute the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of CPTCON
+*
+      END
diff --git a/SRC/cpteqr.f b/SRC/cpteqr.f
new file mode 100644
index 00000000..3483a294
--- /dev/null
+++ b/SRC/cpteqr.f
@@ -0,0 +1,190 @@
+      SUBROUTINE CPTEQR( 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 ..
+      REAL               D( * ), E( * ), WORK( * )
+      COMPLEX            Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTEQR computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric positive definite tridiagonal matrix by first factoring the
+*  matrix using SPTTRF and then calling CBDSQR to compute the singular
+*  values of the bidiagonal factor.
+*
+*  This routine computes the eigenvalues of the positive definite
+*  tridiagonal matrix to high relative accuracy.  This means that if the
+*  eigenvalues range over many orders of magnitude in size, then the
+*  small eigenvalues and corresponding eigenvectors will be computed
+*  more accurately than, for example, with the standard QR method.
+*
+*  The eigenvectors of a full or band positive definite Hermitian matrix
+*  can also be found if CHETRD, CHPTRD, or CHBTRD has been used to
+*  reduce this matrix to tridiagonal form.  (The reduction to
+*  tridiagonal form, however, may preclude the possibility of obtaining
+*  high relative accuracy in the small eigenvalues of the original
+*  matrix, if these eigenvalues range over many orders of magnitude.)
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'V':  Compute eigenvectors of original Hermitian
+*                  matrix also.  Array Z contains the unitary matrix
+*                  used to reduce the original matrix to tridiagonal
+*                  form.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix.
+*          On normal exit, D contains the eigenvalues, in descending
+*          order.
+*
+*  E       (input/output) REAL 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 array, dimension (LDZ, N)
+*          On entry, if COMPZ = 'V', the unitary matrix used in the
+*          reduction to tridiagonal form.
+*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
+*          original Hermitian matrix;
+*          if COMPZ = 'I', the orthonormal eigenvectors of the
+*          tridiagonal matrix.
+*          If INFO > 0 on exit, Z contains the eigenvectors associated
+*          with only the stored eigenvalues.
+*          If  COMPZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          COMPZ = 'V' or 'I', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (4*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 Cholesky factorization of the matrix could
+*                      not be performed because the i-th principal minor
+*                      was not positive definite.
+*                > N   the SVD algorithm failed to converge;
+*                      if INFO = N+i, i off-diagonal elements of the
+*                      bidiagonal factor did not converge to zero.
+*
+*  ====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CBDSQR, CLASET, SPTTRF, XERBLA
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            C( 1, 1 ), VT( 1, 1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICOMPZ, NRU
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+     $         N ) ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPTEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.GT.0 )
+     $      Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+      IF( ICOMPZ.EQ.2 )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
+*
+*     Call SPTTRF to factor the matrix.
+*
+      CALL SPTTRF( N, D, E, INFO )
+      IF( INFO.NE.0 )
+     $   RETURN
+      DO 10 I = 1, N
+         D( I ) = SQRT( D( I ) )
+   10 CONTINUE
+      DO 20 I = 1, N - 1
+         E( I ) = E( I )*D( I )
+   20 CONTINUE
+*
+*     Call CBDSQR to compute the singular values/vectors of the
+*     bidiagonal factor.
+*
+      IF( ICOMPZ.GT.0 ) THEN
+         NRU = N
+      ELSE
+         NRU = 0
+      END IF
+      CALL CBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
+     $             WORK, INFO )
+*
+*     Square the singular values.
+*
+      IF( INFO.EQ.0 ) THEN
+         DO 30 I = 1, N
+            D( I ) = D( I )*D( I )
+   30    CONTINUE
+      ELSE
+         INFO = N + INFO
+      END IF
+*
+      RETURN
+*
+*     End of CPTEQR
+*
+      END
diff --git a/SRC/cptrfs.f b/SRC/cptrfs.f
new file mode 100644
index 00000000..bc487a8b
--- /dev/null
+++ b/SRC/cptrfs.f
@@ -0,0 +1,366 @@
+      SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+     $                   FERR, BERR, WORK, 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, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), D( * ), DF( * ), FERR( * ),
+     $                   RWORK( * )
+      COMPLEX            B( LDB, * ), E( * ), EF( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite
+*  and tridiagonal, and provides error bounds and backward error
+*  estimates for the solution.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the superdiagonal or the subdiagonal of the
+*          tridiagonal matrix A is stored and the form of the
+*          factorization:
+*          = 'U':  E is the superdiagonal of A, and A = U**H*D*U;
+*          = 'L':  E is the subdiagonal of A, and A = L*D*L**H.
+*          (The two forms are equivalent if A is real.)
+*
+*  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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n real diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) COMPLEX array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the tridiagonal matrix A
+*          (see UPLO).
+*
+*  DF      (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from
+*          the factorization computed by CPTTRF.
+*
+*  EF      (input) COMPLEX array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the unit bidiagonal
+*          factor U or L from the factorization computed by CPTTRF
+*          (see UPLO).
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CPTTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL array, dimension (NRHS)
+*          The forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).
+*
+*  BERR    (output) REAL 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) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IX, J, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+      COMPLEX            BI, CX, DX, EX, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CPTTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 100 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X.  Also compute
+*        abs(A)*abs(x) + abs(b) for use in the backward error bound.
+*
+         IF( UPPER ) THEN
+            IF( N.EQ.1 ) THEN
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               WORK( 1 ) = BI - DX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX )
+            ELSE
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               EX = E( 1 )*X( 2, J )
+               WORK( 1 ) = BI - DX - EX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX ) +
+     $                      CABS1( E( 1 ) )*CABS1( X( 2, J ) )
+               DO 30 I = 2, N - 1
+                  BI = B( I, J )
+                  CX = CONJG( E( I-1 ) )*X( I-1, J )
+                  DX = D( I )*X( I, J )
+                  EX = E( I )*X( I+1, J )
+                  WORK( I ) = BI - CX - DX - EX
+                  RWORK( I ) = CABS1( BI ) +
+     $                         CABS1( E( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( DX ) + CABS1( E( I ) )*
+     $                         CABS1( X( I+1, J ) )
+   30          CONTINUE
+               BI = B( N, J )
+               CX = CONJG( E( N-1 ) )*X( N-1, J )
+               DX = D( N )*X( N, J )
+               WORK( N ) = BI - CX - DX
+               RWORK( N ) = CABS1( BI ) + CABS1( E( N-1 ) )*
+     $                      CABS1( X( N-1, J ) ) + CABS1( DX )
+            END IF
+         ELSE
+            IF( N.EQ.1 ) THEN
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               WORK( 1 ) = BI - DX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX )
+            ELSE
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               EX = CONJG( E( 1 ) )*X( 2, J )
+               WORK( 1 ) = BI - DX - EX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX ) +
+     $                      CABS1( E( 1 ) )*CABS1( X( 2, J ) )
+               DO 40 I = 2, N - 1
+                  BI = B( I, J )
+                  CX = E( I-1 )*X( I-1, J )
+                  DX = D( I )*X( I, J )
+                  EX = CONJG( E( I ) )*X( I+1, J )
+                  WORK( I ) = BI - CX - DX - EX
+                  RWORK( I ) = CABS1( BI ) +
+     $                         CABS1( E( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( DX ) + CABS1( E( I ) )*
+     $                         CABS1( X( I+1, J ) )
+   40          CONTINUE
+               BI = B( N, J )
+               CX = E( N-1 )*X( N-1, J )
+               DX = D( N )*X( N, J )
+               WORK( N ) = BI - CX - DX
+               RWORK( N ) = CABS1( BI ) + CABS1( E( N-1 ) )*
+     $                      CABS1( X( N-1, J ) ) + CABS1( DX )
+            END IF
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 50 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+   50    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL CPTTRS( UPLO, N, 1, DF, EF, WORK, N, INFO )
+            CALL CAXPY( N, CMPLX( ONE ), WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+         DO 60 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   60    CONTINUE
+         IX = ISAMAX( N, RWORK, 1 )
+         FERR( J ) = RWORK( IX )
+*
+*        Estimate the norm of inv(A).
+*
+*        Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*           m(i,j) =  abs(A(i,j)), i = j,
+*           m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*        and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*        Solve M(L) * x = e.
+*
+         RWORK( 1 ) = ONE
+         DO 70 I = 2, N
+            RWORK( I ) = ONE + RWORK( I-1 )*ABS( EF( I-1 ) )
+   70    CONTINUE
+*
+*        Solve D * M(L)' * x = b.
+*
+         RWORK( N ) = RWORK( N ) / DF( N )
+         DO 80 I = N - 1, 1, -1
+            RWORK( I ) = RWORK( I ) / DF( I ) +
+     $                   RWORK( I+1 )*ABS( EF( I ) )
+   80    CONTINUE
+*
+*        Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
+*
+         IX = ISAMAX( N, RWORK, 1 )
+         FERR( J ) = FERR( J )*ABS( RWORK( IX ) )
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 90 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+   90    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of CPTRFS
+*
+      END
diff --git a/SRC/cptsv.f b/SRC/cptsv.f
new file mode 100644
index 00000000..dd2dbd52
--- /dev/null
+++ b/SRC/cptsv.f
@@ -0,0 +1,100 @@
+      SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * )
+      COMPLEX            B( LDB, * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTSV computes the solution to a complex system of linear equations
+*  A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal
+*  matrix, and X and B are N-by-NRHS matrices.
+*
+*  A is factored as A = L*D*L**H, and the factored form of A is then
+*  used to solve the system of equations.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the factorization A = L*D*L**H.
+*
+*  E       (input/output) COMPLEX array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L**H factorization of
+*          A.  E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U**H*D*U factorization of A.
+*
+*  B       (input/output) COMPLEX 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).
+*
+*  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 solution has not been
+*                computed.  The factorization has not been completed
+*                unless i = N.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           CPTTRF, CPTTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPTSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      CALL CPTTRF( N, D, E, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CPTTRS( 'Lower', N, NRHS, D, E, B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of CPTSV
+*
+      END
diff --git a/SRC/cptsvx.f b/SRC/cptsvx.f
new file mode 100644
index 00000000..3abfa46c
--- /dev/null
+++ b/SRC/cptsvx.f
@@ -0,0 +1,236 @@
+      SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), D( * ), DF( * ), FERR( * ),
+     $                   RWORK( * )
+      COMPLEX            B( LDB, * ), E( * ), EF( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTSVX uses the factorization A = L*D*L**H to compute the solution
+*  to a complex system of linear equations A*X = B, where A is an
+*  N-by-N Hermitian positive definite tridiagonal matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L
+*     is a unit lower bidiagonal matrix and D is diagonal.  The
+*     factorization can also be regarded as having the form
+*     A = U**H*D*U.
+*
+*  2. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of the matrix
+*          A is supplied on entry.
+*          = 'F':  On entry, DF and EF contain the factored form of A.
+*                  D, E, DF, and EF will not be modified.
+*          = 'N':  The matrix A will be copied to DF and EF and
+*                  factored.
+*
+*  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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) COMPLEX array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+*  DF      (input or output) REAL array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**H factorization of A.
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**H factorization of A.
+*
+*  EF      (input or output) COMPLEX array, dimension (N-1)
+*          If FACT = 'F', then EF is an input argument and on entry
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**H factorization of A.
+*          If FACT = 'N', then EF is an output argument and on exit
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**H factorization of A.
+*
+*  B       (input) COMPLEX array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The reciprocal condition number of the matrix A.  If RCOND
+*          is less than the machine precision (in particular, if
+*          RCOND = 0), the matrix is singular to working precision.
+*          This condition is indicated by a return code of INFO > 0.
+*
+*  FERR    (output) REAL array, dimension (NRHS)
+*          The forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).
+*
+*  BERR    (output) REAL 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) COMPLEX array, dimension (N)
+*
+*  RWORK   (workspace) REAL 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:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANHT, SLAMCH
+      EXTERNAL           LSAME, CLANHT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CPTCON, CPTRFS, CPTTRF, CPTTRS,
+     $                   SCOPY, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+         CALL SCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 )
+     $      CALL CCOPY( N-1, E, 1, EF, 1 )
+         CALL CPTTRF( N, DF, EF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANHT( '1', N, D, E )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CPTCON( N, DF, EF, ANORM, RCOND, RWORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CPTTRS( 'Lower', N, NRHS, DF, EF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL CPTRFS( 'Lower', N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CPTSVX
+*
+      END
diff --git a/SRC/cpttrf.f b/SRC/cpttrf.f
new file mode 100644
index 00000000..e02daf95
--- /dev/null
+++ b/SRC/cpttrf.f
@@ -0,0 +1,168 @@
+      SUBROUTINE CPTTRF( 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 ..
+      REAL               D( * )
+      COMPLEX            E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTTRF computes the L*D*L' factorization of a complex Hermitian
+*  positive definite tridiagonal matrix A.  The factorization may also
+*  be regarded as having the form A = U'*D*U.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the L*D*L' factorization of A.
+*
+*  E       (input/output) COMPLEX array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L' factorization of A.
+*          E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U'*D*U factorization of A.
+*
+*  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; if k < N, the factorization could not
+*               be completed, while if k = N, the factorization was
+*               completed, but D(N) <= 0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I4
+      REAL               EII, EIR, F, G
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          AIMAG, CMPLX, MOD, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'CPTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      I4 = MOD( N-1, 4 )
+      DO 10 I = 1, I4
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 20
+         END IF
+         EIR = REAL( E( I ) )
+         EII = AIMAG( E( I ) )
+         F = EIR / D( I )
+         G = EII / D( I )
+         E( I ) = CMPLX( F, G )
+         D( I+1 ) = D( I+1 ) - F*EIR - G*EII
+   10 CONTINUE
+*
+      DO 110 I = I4+1, N - 4, 4
+*
+*        Drop out of the loop if d(i) <= 0: the matrix is not positive
+*        definite.
+*
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 20
+         END IF
+*
+*        Solve for e(i) and d(i+1).
+*
+         EIR = REAL( E( I ) )
+         EII = AIMAG( E( I ) )
+         F = EIR / D( I )
+         G = EII / D( I )
+         E( I ) = CMPLX( F, G )
+         D( I+1 ) = D( I+1 ) - F*EIR - G*EII
+*
+         IF( D( I+1 ).LE.ZERO ) THEN
+            INFO = I+1
+            GO TO 20
+         END IF
+*
+*        Solve for e(i+1) and d(i+2).
+*
+         EIR = REAL( E( I+1 ) )
+         EII = AIMAG( E( I+1 ) )
+         F = EIR / D( I+1 )
+         G = EII / D( I+1 )
+         E( I+1 ) = CMPLX( F, G )
+         D( I+2 ) = D( I+2 ) - F*EIR - G*EII
+*
+         IF( D( I+2 ).LE.ZERO ) THEN
+            INFO = I+2
+            GO TO 20
+         END IF
+*
+*        Solve for e(i+2) and d(i+3).
+*
+         EIR = REAL( E( I+2 ) )
+         EII = AIMAG( E( I+2 ) )
+         F = EIR / D( I+2 )
+         G = EII / D( I+2 )
+         E( I+2 ) = CMPLX( F, G )
+         D( I+3 ) = D( I+3 ) - F*EIR - G*EII
+*
+         IF( D( I+3 ).LE.ZERO ) THEN
+            INFO = I+3
+            GO TO 20
+         END IF
+*
+*        Solve for e(i+3) and d(i+4).
+*
+         EIR = REAL( E( I+3 ) )
+         EII = AIMAG( E( I+3 ) )
+         F = EIR / D( I+3 )
+         G = EII / D( I+3 )
+         E( I+3 ) = CMPLX( F, G )
+         D( I+4 ) = D( I+4 ) - F*EIR - G*EII
+  110 CONTINUE
+*
+*     Check d(n) for positive definiteness.
+*
+      IF( D( N ).LE.ZERO )
+     $   INFO = N
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of CPTTRF
+*
+      END
diff --git a/SRC/cpttrs.f b/SRC/cpttrs.f
new file mode 100644
index 00000000..b875ffae
--- /dev/null
+++ b/SRC/cpttrs.f
@@ -0,0 +1,135 @@
+      SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * )
+      COMPLEX            B( LDB, * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTTRS solves a tridiagonal system of the form
+*     A * X = B
+*  using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.
+*  D is a diagonal matrix specified in the vector D, U (or L) is a unit
+*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
+*  the vector E, and X and B are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies the form of the factorization and whether the
+*          vector E is the superdiagonal of the upper bidiagonal factor
+*          U or the subdiagonal of the lower bidiagonal factor L.
+*          = 'U':  A = U'*D*U, E is the superdiagonal of U
+*          = 'L':  A = L*D*L', E is the subdiagonal of L
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization A = U'*D*U or A = L*D*L'.
+*
+*  E       (input) COMPLEX array, dimension (N-1)
+*          If UPLO = 'U', the (n-1) superdiagonal elements of the unit
+*          bidiagonal factor U from the factorization A = U'*D*U.
+*          If UPLO = 'L', the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the factorization A = L*D*L'.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            IUPLO, J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CPTTS2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      UPPER = ( UPLO.EQ.'U' .OR. UPLO.EQ.'u' )
+      IF( .NOT.UPPER .AND. .NOT.( UPLO.EQ.'L' .OR. UPLO.EQ.'l' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CPTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'CPTTRS', UPLO, N, NRHS, -1, -1 ) )
+      END IF
+*
+*     Decode UPLO
+*
+      IF( UPPER ) THEN
+         IUPLO = 1
+      ELSE
+         IUPLO = 0
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL CPTTS2( IUPLO, N, JB, D, E, B( 1, J ), LDB )
+   10    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CPTTRS
+*
+      END
diff --git a/SRC/cptts2.f b/SRC/cptts2.f
new file mode 100644
index 00000000..95d835e0
--- /dev/null
+++ b/SRC/cptts2.f
@@ -0,0 +1,176 @@
+      SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IUPLO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * )
+      COMPLEX            B( LDB, * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CPTTS2 solves a tridiagonal system of the form
+*     A * X = B
+*  using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.
+*  D is a diagonal matrix specified in the vector D, U (or L) is a unit
+*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
+*  the vector E, and X and B are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  IUPLO   (input) INTEGER
+*          Specifies the form of the factorization and whether the
+*          vector E is the superdiagonal of the upper bidiagonal factor
+*          U or the subdiagonal of the lower bidiagonal factor L.
+*          = 1:  A = U'*D*U, E is the superdiagonal of U
+*          = 0:  A = L*D*L', E is the subdiagonal of L
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization A = U'*D*U or A = L*D*L'.
+*
+*  E       (input) COMPLEX array, dimension (N-1)
+*          If IUPLO = 1, the (n-1) superdiagonal elements of the unit
+*          bidiagonal factor U from the factorization A = U'*D*U.
+*          If IUPLO = 0, the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the factorization A = L*D*L'.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         IF( N.EQ.1 )
+     $      CALL CSSCAL( NRHS, 1. / D( 1 ), B, LDB )
+         RETURN
+      END IF
+*
+      IF( IUPLO.EQ.1 ) THEN
+*
+*        Solve A * X = B using the factorization A = U'*D*U,
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.2 ) THEN
+            J = 1
+    5       CONTINUE
+*
+*           Solve U' * x = b.
+*
+            DO 10 I = 2, N
+               B( I, J ) = B( I, J ) - B( I-1, J )*CONJG( E( I-1 ) )
+   10       CONTINUE
+*
+*           Solve D * U * x = b.
+*
+            DO 20 I = 1, N
+               B( I, J ) = B( I, J ) / D( I )
+   20       CONTINUE
+            DO 30 I = N - 1, 1, -1
+               B( I, J ) = B( I, J ) - B( I+1, J )*E( I )
+   30       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 5
+            END IF
+         ELSE
+            DO 60 J = 1, NRHS
+*
+*              Solve U' * x = b.
+*
+               DO 40 I = 2, N
+                  B( I, J ) = B( I, J ) - B( I-1, J )*CONJG( E( I-1 ) )
+   40          CONTINUE
+*
+*              Solve D * U * x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               DO 50 I = N - 1, 1, -1
+                  B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
+   50          CONTINUE
+   60       CONTINUE
+         END IF
+      ELSE
+*
+*        Solve A * X = B using the factorization A = L*D*L',
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.2 ) THEN
+            J = 1
+   65       CONTINUE
+*
+*           Solve L * x = b.
+*
+            DO 70 I = 2, N
+               B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+   70       CONTINUE
+*
+*           Solve D * L' * x = b.
+*
+            DO 80 I = 1, N
+               B( I, J ) = B( I, J ) / D( I )
+   80       CONTINUE
+            DO 90 I = N - 1, 1, -1
+               B( I, J ) = B( I, J ) - B( I+1, J )*CONJG( E( I ) )
+   90       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 65
+            END IF
+         ELSE
+            DO 120 J = 1, NRHS
+*
+*              Solve L * x = b.
+*
+               DO 100 I = 2, N
+                  B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+  100          CONTINUE
+*
+*              Solve D * L' * x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               DO 110 I = N - 1, 1, -1
+                  B( I, J ) = B( I, J ) / D( I ) -
+     $                        B( I+1, J )*CONJG( E( I ) )
+  110          CONTINUE
+  120       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CPTTS2
+*
+      END
diff --git a/SRC/crot.f b/SRC/crot.f
new file mode 100644
index 00000000..fe973694
--- /dev/null
+++ b/SRC/crot.f
@@ -0,0 +1,91 @@
+      SUBROUTINE CROT( 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
+      REAL               C
+      COMPLEX            S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            CX( * ), CY( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CROT   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 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 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) REAL
+*  S       (input) COMPLEX
+*          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            STEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG
+*     ..
+*     .. 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 ) - CONJG( 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 ) - CONJG( S )*CX( I )
+         CX( I ) = STEMP
+   30 CONTINUE
+      RETURN
+      END
diff --git a/SRC/cspcon.f b/SRC/cspcon.f
new file mode 100644
index 00000000..bfab77ba
--- /dev/null
+++ b/SRC/cspcon.f
@@ -0,0 +1,159 @@
+      SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex symmetric packed matrix A using the
+*  factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CSPTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IP, KASE
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CSPTRS, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         IP = N*( N+1 ) / 2
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP - I
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         IP = 1
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP + N - I + 1
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL CSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of CSPCON
+*
+      END
diff --git a/SRC/cspmv.f b/SRC/cspmv.f
new file mode 100644
index 00000000..aff8085d
--- /dev/null
+++ b/SRC/cspmv.f
@@ -0,0 +1,264 @@
+      SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INCX, INCY, N
+      COMPLEX            ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPMV  performs the matrix-vector operation
+*
+*     y := alpha*A*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are n element vectors and
+*  A is an n by n symmetric matrix, supplied in packed form.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the matrix A is supplied in the packed
+*           array AP as follows:
+*
+*              UPLO = 'U' or 'u'   The upper triangular part of A is
+*                                  supplied in AP.
+*
+*              UPLO = 'L' or 'l'   The lower triangular part of A is
+*                                  supplied in AP.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  AP       (input) COMPLEX array, dimension at least
+*           ( ( N*( N + 1 ) )/2 ).
+*           Before entry, with UPLO = 'U' or 'u', the array AP must
+*           contain the upper triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+*           and a( 2, 2 ) respectively, and so on.
+*           Before entry, with UPLO = 'L' or 'l', the array AP must
+*           contain the lower triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+*           and a( 3, 1 ) respectively, and so on.
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA     (input) COMPLEX
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y        (input/output) COMPLEX array, dimension at least 
+*           ( 1 + ( N - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y. On exit, Y is overwritten by the updated
+*           vector y.
+*
+*  INCY     (input) INTEGER
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
+      COMPLEX            TEMP1, TEMP2
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 6
+      ELSE IF( INCY.EQ.0 ) THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     Set up the start points in  X  and  Y.
+*
+      IF( INCX.GT.0 ) THEN
+         KX = 1
+      ELSE
+         KX = 1 - ( N-1 )*INCX
+      END IF
+      IF( INCY.GT.0 ) THEN
+         KY = 1
+      ELSE
+         KY = 1 - ( N-1 )*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of the array AP
+*     are accessed sequentially with one pass through AP.
+*
+*     First form  y := beta*y.
+*
+      IF( BETA.NE.ONE ) THEN
+         IF( INCY.EQ.1 ) THEN
+            IF( BETA.EQ.ZERO ) THEN
+               DO 10 I = 1, N
+                  Y( I ) = ZERO
+   10          CONTINUE
+            ELSE
+               DO 20 I = 1, N
+                  Y( I ) = BETA*Y( I )
+   20          CONTINUE
+            END IF
+         ELSE
+            IY = KY
+            IF( BETA.EQ.ZERO ) THEN
+               DO 30 I = 1, N
+                  Y( IY ) = ZERO
+                  IY = IY + INCY
+   30          CONTINUE
+            ELSE
+               DO 40 I = 1, N
+                  Y( IY ) = BETA*Y( IY )
+                  IY = IY + INCY
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      IF( ALPHA.EQ.ZERO )
+     $   RETURN
+      KK = 1
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  y  when AP contains the upper triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 60 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               K = KK
+               DO 50 I = 1, J - 1
+                  Y( I ) = Y( I ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( I )
+                  K = K + 1
+   50          CONTINUE
+               Y( J ) = Y( J ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
+               KK = KK + J
+   60       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 80 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               IX = KX
+               IY = KY
+               DO 70 K = KK, KK + J - 2
+                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( IX )
+                  IX = IX + INCX
+                  IY = IY + INCY
+   70          CONTINUE
+               Y( JY ) = Y( JY ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+               KK = KK + J
+   80       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  y  when AP contains the lower triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 100 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               Y( J ) = Y( J ) + TEMP1*AP( KK )
+               K = KK + 1
+               DO 90 I = J + 1, N
+                  Y( I ) = Y( I ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( I )
+                  K = K + 1
+   90          CONTINUE
+               Y( J ) = Y( J ) + ALPHA*TEMP2
+               KK = KK + ( N-J+1 )
+  100       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 120 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               Y( JY ) = Y( JY ) + TEMP1*AP( KK )
+               IX = JX
+               IY = JY
+               DO 110 K = KK + 1, KK + N - J
+                  IX = IX + INCX
+                  IY = IY + INCY
+                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( IX )
+  110          CONTINUE
+               Y( JY ) = Y( JY ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+               KK = KK + ( N-J+1 )
+  120       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CSPMV
+*
+      END
diff --git a/SRC/cspr.f b/SRC/cspr.f
new file mode 100644
index 00000000..c10e3555
--- /dev/null
+++ b/SRC/cspr.f
@@ -0,0 +1,213 @@
+      SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INCX, N
+      COMPLEX            ALPHA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPR    performs the symmetric rank 1 operation
+*
+*     A := alpha*x*conjg( x' ) + A,
+*
+*  where alpha is a complex scalar, x is an n element vector and A is an
+*  n by n symmetric matrix, supplied in packed form.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the matrix A is supplied in the packed
+*           array AP as follows:
+*
+*              UPLO = 'U' or 'u'   The upper triangular part of A is
+*                                  supplied in AP.
+*
+*              UPLO = 'L' or 'l'   The lower triangular part of A is
+*                                  supplied in AP.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  AP       (input/output) COMPLEX array, dimension at least
+*           ( ( N*( N + 1 ) )/2 ).
+*           Before entry, with  UPLO = 'U' or 'u', the array AP must
+*           contain the upper triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+*           and a( 2, 2 ) respectively, and so on. On exit, the array
+*           AP is overwritten by the upper triangular part of the
+*           updated matrix.
+*           Before entry, with UPLO = 'L' or 'l', the array AP must
+*           contain the lower triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+*           and a( 3, 1 ) respectively, and so on. On exit, the array
+*           AP is overwritten by the lower triangular part of the
+*           updated matrix.
+*           Note that the imaginary parts of the diagonal elements need
+*           not be set, they are assumed to be zero, and on exit they
+*           are set to zero.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, J, JX, K, KK, KX
+      COMPLEX            TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPR  ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Set the start point in X if the increment is not unity.
+*
+      IF( INCX.LE.0 ) THEN
+         KX = 1 - ( N-1 )*INCX
+      ELSE IF( INCX.NE.1 ) THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of the array AP
+*     are accessed sequentially with one pass through AP.
+*
+      KK = 1
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  A  when upper triangle is stored in AP.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 20 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  K = KK
+                  DO 10 I = 1, J - 1
+                     AP( K ) = AP( K ) + X( I )*TEMP
+                     K = K + 1
+   10             CONTINUE
+                  AP( KK+J-1 ) = AP( KK+J-1 ) + X( J )*TEMP
+               ELSE
+                  AP( KK+J-1 ) = AP( KK+J-1 )
+               END IF
+               KK = KK + J
+   20       CONTINUE
+         ELSE
+            JX = KX
+            DO 40 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  IX = KX
+                  DO 30 K = KK, KK + J - 2
+                     AP( K ) = AP( K ) + X( IX )*TEMP
+                     IX = IX + INCX
+   30             CONTINUE
+                  AP( KK+J-1 ) = AP( KK+J-1 ) + X( JX )*TEMP
+               ELSE
+                  AP( KK+J-1 ) = AP( KK+J-1 )
+               END IF
+               JX = JX + INCX
+               KK = KK + J
+   40       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  A  when lower triangle is stored in AP.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 60 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  AP( KK ) = AP( KK ) + TEMP*X( J )
+                  K = KK + 1
+                  DO 50 I = J + 1, N
+                     AP( K ) = AP( K ) + X( I )*TEMP
+                     K = K + 1
+   50             CONTINUE
+               ELSE
+                  AP( KK ) = AP( KK )
+               END IF
+               KK = KK + N - J + 1
+   60       CONTINUE
+         ELSE
+            JX = KX
+            DO 80 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  AP( KK ) = AP( KK ) + TEMP*X( JX )
+                  IX = JX
+                  DO 70 K = KK + 1, KK + N - J
+                     IX = IX + INCX
+                     AP( K ) = AP( K ) + X( IX )*TEMP
+   70             CONTINUE
+               ELSE
+                  AP( KK ) = AP( KK )
+               END IF
+               JX = JX + INCX
+               KK = KK + N - J + 1
+   80       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CSPR
+*
+      END
diff --git a/SRC/csprfs.f b/SRC/csprfs.f
new file mode 100644
index 00000000..430cec52
--- /dev/null
+++ b/SRC/csprfs.f
@@ -0,0 +1,340 @@
+      SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
+     $                   FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  AFP     (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The factored form of the matrix A.  AFP contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by CSPTRF, stored as a packed
+*          triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CSPTRF.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CSPTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CLACN2, CSPMV, CSPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + CABS1( AP( KK+K-1 ) )*XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + CABS1( AP( KK ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CSPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CSPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CSPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CSPRFS
+*
+      END
diff --git a/SRC/cspsv.f b/SRC/cspsv.f
new file mode 100644
index 00000000..b07ed386
--- /dev/null
+++ b/SRC/cspsv.f
@@ -0,0 +1,148 @@
+      SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric matrix stored in packed format and X
+*  and B are N-by-NRHS matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**T,  if UPLO = 'U', or
+*     A = L * D * L**T,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, D is symmetric and block diagonal with 1-by-1
+*  and 2-by-2 diagonal blocks.  The factored form of A is then used to
+*  solve the system of equations A * X = B.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by CSPTRF.  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) COMPLEX 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).
+*
+*  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.
+*
+*  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 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSPTRF, CSPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL CSPTRF( UPLO, N, AP, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of CSPSV
+*
+      END
diff --git a/SRC/cspsvx.f b/SRC/cspsvx.f
new file mode 100644
index 00000000..fbf6cede
--- /dev/null
+++ b/SRC/cspsvx.f
@@ -0,0 +1,277 @@
+      SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
+     $                   LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
+*  A = L*D*L**T to compute the solution to a complex system of linear
+*  equations A * X = B, where A is an N-by-N symmetric matrix stored
+*  in packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AFP and IPIV contain the factored form
+*                  of A.  AP, AFP and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*  AFP     (input or output) COMPLEX array, dimension (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains details of the interchanges and the block structure
+*          of D, as determined by CSPTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by CSPTRF.
+*
+*  B       (input) COMPLEX array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANSP, SLAMCH
+      EXTERNAL           LSAME, CLANSP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLACPY, CSPCON, CSPRFS, CSPTRF, CSPTRS,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL CCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL CSPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANSP( 'I', UPLO, N, AP, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of CSPSVX
+*
+      END
diff --git a/SRC/csptrf.f b/SRC/csptrf.f
new file mode 100644
index 00000000..7944fe1d
--- /dev/null
+++ b/SRC/csptrf.f
@@ -0,0 +1,555 @@
+      SUBROUTINE CSPTRF( 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( * )
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPTRF computes the factorization of a complex 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) COMPLEX 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
+     $                   KSTEP, KX, NPP
+      REAL               ABSAKK, ALPHA, COLMAX, ROWMAX
+      COMPLEX            D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      EXTERNAL           LSAME, ICAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSCAL, CSPR, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CSPTRF', -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 = CABS1( 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 = ICAMAX( K-1, AP( KC ), 1 )
+            COLMAX = CABS1( 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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( AP( KX ) )
+                     JMAX = J
+                  END IF
+                  KX = KX + J
+   20          CONTINUE
+               KPC = ( IMAX-1 )*IMAX / 2 + 1
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ICAMAX( IMAX-1, AP( KPC ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 CSWAP( 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 = CONE / AP( KC+K-1 )
+               CALL CSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+*              Store U(k) in column k
+*
+               CALL CSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 = CABS1( 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 + ICAMAX( N-K, AP( KC+1 ), 1 )
+            COLMAX = CABS1( 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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( 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 + ICAMAX( N-IMAX, AP( KPC+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 CSWAP( 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 = CONE / AP( KC )
+                  CALL CSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+     $                       AP( KC+N-K+1 ) )
+*
+*                 Store L(k) in column K
+*
+                  CALL CSCAL( 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) )'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
+                  D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
+                  D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
+                  T = CONE / ( D11*D22-CONE )
+                  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 CSPTRF
+*
+      END
diff --git a/SRC/csptri.f b/SRC/csptri.f
new file mode 100644
index 00000000..d63a9ad1
--- /dev/null
+++ b/SRC/csptri.f
@@ -0,0 +1,337 @@
+      SUBROUTINE CSPTRI( UPLO, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPTRI computes the inverse of a complex symmetric indefinite matrix
+*  A in packed storage using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by CSPTRF.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by CSPTRF,
+*          stored as a packed triangular matrix.
+*
+*          On exit, if INFO = 0, the (symmetric) inverse of the original
+*          matrix, stored as a packed triangular matrix. The j-th column
+*          of inv(A) is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+*          if UPLO = 'L',
+*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CSPTRF.
+*
+*  WORK    (workspace) COMPLEX 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 ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+      COMPLEX            AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTU
+      EXTERNAL           LSAME, CDOTU
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CSPMV, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         KP = N*( N+1 ) / 2
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP - INFO
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         KP = 1
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP + N - INFO + 1
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         KCNEXT = KC + K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC+K-1 ) = ONE / AP( KC+K-1 )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL CCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL CSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        CDOTU( K-1, WORK, 1, AP( KC ), 1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = AP( KCNEXT+K-1 )
+            AK = AP( KC+K-1 ) / T
+            AKP1 = AP( KCNEXT+K ) / T
+            AKKP1 = AP( KCNEXT+K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KC+K-1 ) = AKP1 / D
+            AP( KCNEXT+K ) = AK / D
+            AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL CCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL CSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        CDOTU( K-1, WORK, 1, AP( KC ), 1 )
+               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+     $                            CDOTU( K-1, AP( KC ), 1, AP( KCNEXT ),
+     $                            1 )
+               CALL CCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+               CALL CSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
+     $                     AP( KCNEXT ), 1 )
+               AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+     $                          CDOTU( K-1, WORK, 1, AP( KCNEXT ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT + K + 1
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            KPC = ( KP-1 )*KP / 2 + 1
+            CALL CSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+            KX = KPC + KP - 1
+            DO 40 J = KP + 1, K - 1
+               KX = KX + J - 1
+               TEMP = AP( KC+J-1 )
+               AP( KC+J-1 ) = AP( KX )
+               AP( KX ) = TEMP
+   40       CONTINUE
+            TEMP = AP( KC+K-1 )
+            AP( KC+K-1 ) = AP( KPC+KP-1 )
+            AP( KPC+KP-1 ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC+K+K-1 )
+               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+               AP( KC+K+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         KC = KCNEXT
+         GO TO 30
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         NPP = N*( N+1 ) / 2
+         K = N
+         KC = NPP
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         KCNEXT = KC - ( N-K+2 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC ) = ONE / AP( KC )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL CCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL CSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - CDOTU( N-K, WORK, 1, AP( KC+1 ),
+     $                    1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = AP( KCNEXT+1 )
+            AK = AP( KCNEXT ) / T
+            AKP1 = AP( KC ) / T
+            AKKP1 = AP( KCNEXT+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KCNEXT ) = AKP1 / D
+            AP( KC ) = AK / D
+            AP( KCNEXT+1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL CCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL CSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - CDOTU( N-K, WORK, 1, AP( KC+1 ),
+     $                    1 )
+               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+     $                          CDOTU( N-K, AP( KC+1 ), 1,
+     $                          AP( KCNEXT+2 ), 1 )
+               CALL CCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+               CALL CSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KCNEXT+2 ), 1 )
+               AP( KCNEXT ) = AP( KCNEXT ) -
+     $                        CDOTU( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT - ( N-K+3 )
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+            IF( KP.LT.N )
+     $         CALL CSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+            KX = KC + KP - K
+            DO 70 J = K + 1, KP - 1
+               KX = KX + N - J + 1
+               TEMP = AP( KC+J-K )
+               AP( KC+J-K ) = AP( KX )
+               AP( KX ) = TEMP
+   70       CONTINUE
+            TEMP = AP( KC )
+            AP( KC ) = AP( KPC )
+            AP( KPC ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC-N+K-1 )
+               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+               AP( KC-N+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         KC = KCNEXT
+         GO TO 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CSPTRI
+*
+      END
diff --git a/SRC/csptrs.f b/SRC/csptrs.f
new file mode 100644
index 00000000..7746149d
--- /dev/null
+++ b/SRC/csptrs.f
@@ -0,0 +1,377 @@
+      SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSPTRS solves a system of linear equations A*X = B with a complex
+*  symmetric matrix A stored in packed format using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by CSPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CSPTRF.
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KP
+      COMPLEX            AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CGERU, CSCAL, CSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSPTRS', -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
+         KC = N*( N+1 ) / 2 + 1
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         KC = KC - K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL CSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K-1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K-1 )
+     $         CALL CSWAP( 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 CGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL CGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+     $                  B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+K-2 )
+            AKM1 = AP( KC-1 ) / AKM1K
+            AK = AP( KC+K-1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / AKM1K
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            KC = KC - K + 1
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + K
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            CALL CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+     $                  AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + 2*K + 1
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+     $                     LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL CSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
+            KC = KC + N - K + 1
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL CSWAP( 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 CGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL CGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+     $                     B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+1 )
+            AKM1 = AP( KC ) / AKM1K
+            AK = AP( KC+N-K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / AKM1K
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            KC = KC + 2*( N-K ) + 1
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         KC = KC - ( N-K+1 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( 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 CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+               CALL CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
+     $                     LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC - ( N-K+2 )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CSPTRS
+*
+      END
diff --git a/SRC/csrscl.f b/SRC/csrscl.f
new file mode 100644
index 00000000..3e7345c0
--- /dev/null
+++ b/SRC/csrscl.f
@@ -0,0 +1,114 @@
+      SUBROUTINE CSRSCL( 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
+      REAL               SA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            SX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSRSCL 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) REAL
+*          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 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      REAL               BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSSCAL, SLABAD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( 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 CSSCAL( N, MUL, SX, INCX )
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of CSRSCL
+*
+      END
diff --git a/SRC/cstedc.f b/SRC/cstedc.f
new file mode 100644
index 00000000..a2ed1cb0
--- /dev/null
+++ b/SRC/cstedc.f
@@ -0,0 +1,403 @@
+      SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
+     $                   LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), RWORK( * )
+      COMPLEX            WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSTEDC computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric tridiagonal matrix using the divide and conquer method.
+*  The eigenvectors of a full or band complex Hermitian matrix can also
+*  be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this
+*  matrix to tridiagonal form.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.  See SLAED3 for details.
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*          = 'V':  Compute eigenvectors of original Hermitian matrix
+*                  also.  On entry, Z contains the unitary matrix used
+*                  to reduce the original matrix to tridiagonal form.
+*
+*  N       (input) INTEGER
+*          The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D       (input/output) REAL 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) REAL array, dimension (N-1)
+*          On entry, the subdiagonal elements of the tridiagonal matrix.
+*          On exit, E has been destroyed.
+*
+*  Z       (input/output) COMPLEX 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.
+*          If eigenvectors are desired, then LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) COMPLEX    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 COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
+*          Note that for COMPZ = 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LWORK need
+*          only be 1.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of the array RWORK.
+*          If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1, LRWORK must be at least
+*                         1 + 3*N + 2*N*lg N + 3*N**2 ,
+*                         where lg( N ) = smallest integer k such
+*                         that 2**k >= N.
+*          If COMPZ = 'I' and N > 1, LRWORK must be at least
+*                         1 + 4*N + 2*N**2 .
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LRWORK
+*          need only be max(1,2*(N-1)).
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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.
+*          If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
+*          If COMPZ = 'V' or N > 1,  LIWORK must be at least
+*                                    6 + 6*N + 5*N*lg N.
+*          If COMPZ = 'I' or N > 1,  LIWORK must be at least
+*                                    3 + 5*N .
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LIWORK
+*          need only be 1.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
+     $                   LRWMIN, LWMIN, M, SMLSIZ, START
+      REAL               EPS, ORGNRM, P, TINY
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANST
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, CLACPY, CLACRM, CLAED0, CSTEQR, CSWAP,
+     $                   SLASCL, SLASET, SSTEDC, SSTEQR, SSTERF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MOD, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR.
+     $         ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Compute the workspace requirements
+*
+         SMLSIZ = ILAENV( 9, 'CSTEDC', ' ', 0, 0, 0, 0 )
+         IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 1
+         ELSE IF( N.LE.SMLSIZ ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 2*( N - 1 )
+         ELSE IF( ICOMPZ.EQ.1 ) THEN
+            LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) )
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            LWMIN = N*N
+            LRWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
+            LIWMIN = 6 + 6*N + 5*N*LGN
+         ELSE IF( ICOMPZ.EQ.2 ) THEN
+            LWMIN = 1
+            LRWMIN = 1 + 4*N + 2*N**2
+            LIWMIN = 3 + 5*N
+         END IF
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSTEDC', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.NE.0 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     If the following conditional clause is removed, then the routine
+*     will use the Divide and Conquer routine to compute only the
+*     eigenvalues, which requires (3N + 3N**2) real workspace and
+*     (2 + 5N + 2N lg(N)) integer workspace.
+*     Since on many architectures SSTERF is much faster than any other
+*     algorithm for finding eigenvalues only, it is used here
+*     as the default. If the conditional clause is removed, then
+*     information on the size of workspace needs to be changed.
+*
+*     If COMPZ = 'N', use SSTERF to compute the eigenvalues.
+*
+      IF( ICOMPZ.EQ.0 ) THEN
+         CALL SSTERF( N, D, E, INFO )
+         GO TO 70
+      END IF
+*
+*     If N is smaller than the minimum divide size (SMLSIZ+1), then
+*     solve the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+*
+         CALL CSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
+*
+      ELSE
+*
+*        If COMPZ = 'I', we simply call SSTEDC instead.
+*
+         IF( ICOMPZ.EQ.2 ) THEN
+            CALL SLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
+            LL = N*N + 1
+            CALL SSTEDC( 'I', N, D, E, RWORK, N,
+     $                   RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO )
+            DO 20 J = 1, N
+               DO 10 I = 1, N
+                  Z( I, J ) = RWORK( ( J-1 )*N+I )
+   10          CONTINUE
+   20       CONTINUE
+            GO TO 70
+         END IF
+*
+*        From now on, only option left to be handled is COMPZ = 'V',
+*        i.e. ICOMPZ = 1.
+*
+*        Scale.
+*
+         ORGNRM = SLANST( 'M', N, D, E )
+         IF( ORGNRM.EQ.ZERO )
+     $      GO TO 70
+*
+         EPS = SLAMCH( 'Epsilon' )
+*
+         START = 1
+*
+*        while ( START <= N )
+*
+   30    CONTINUE
+         IF( START.LE.N ) THEN
+*
+*           Let FINISH be the position of the next subdiagonal entry
+*           such that E( FINISH ) <= TINY or FINISH = N if no such
+*           subdiagonal exists.  The matrix identified by the elements
+*           between START and FINISH constitutes an independent
+*           sub-problem.
+*
+            FINISH = START
+   40       CONTINUE
+            IF( FINISH.LT.N ) THEN
+               TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
+     $                    SQRT( ABS( D( FINISH+1 ) ) )
+               IF( ABS( E( FINISH ) ).GT.TINY ) THEN
+                  FINISH = FINISH + 1
+                  GO TO 40
+               END IF
+            END IF
+*
+*           (Sub) Problem determined.  Compute its size and solve it.
+*
+            M = FINISH - START + 1
+            IF( M.GT.SMLSIZ ) THEN
+*
+*              Scale.
+*
+               ORGNRM = SLANST( 'M', M, D( START ), E( START ) )
+               CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
+     $                      INFO )
+               CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
+     $                      M-1, INFO )
+*
+               CALL CLAED0( N, M, D( START ), E( START ), Z( 1, START ),
+     $                      LDZ, WORK, N, RWORK, IWORK, INFO )
+               IF( INFO.GT.0 ) THEN
+                  INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
+     $                   MOD( INFO, ( M+1 ) ) + START - 1
+                  GO TO 70
+               END IF
+*
+*              Scale back.
+*
+               CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
+     $                      INFO )
+*
+            ELSE
+               CALL SSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
+     $                      RWORK( M*M+1 ), INFO )
+               CALL CLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N,
+     $                      RWORK( M*M+1 ) )
+               CALL CLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ )
+               IF( INFO.GT.0 ) THEN
+                  INFO = START*( N+1 ) + FINISH
+                  GO TO 70
+               END IF
+            END IF
+*
+            START = FINISH + 1
+            GO TO 30
+         END IF
+*
+*        endwhile
+*
+*        If the problem split any number of times, then the eigenvalues
+*        will not be properly ordered.  Here we permute the eigenvalues
+*        (and the associated eigenvectors) into ascending order.
+*
+         IF( M.NE.N ) THEN
+*
+*           Use Selection Sort to minimize swaps of eigenvectors
+*
+            DO 60 II = 2, N
+               I = II - 1
+               K = I
+               P = D( I )
+               DO 50 J = II, N
+                  IF( D( J ).LT.P ) THEN
+                     K = J
+                     P = D( J )
+                  END IF
+   50          CONTINUE
+               IF( K.NE.I ) THEN
+                  D( K ) = D( I )
+                  D( I ) = P
+                  CALL CSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+               END IF
+   60       CONTINUE
+         END IF
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of CSTEDC
+*
+      END
diff --git a/SRC/cstegr.f b/SRC/cstegr.f
new file mode 100644
index 00000000..ff3ff3f6
--- /dev/null
+++ b/SRC/cstegr.f
@@ -0,0 +1,180 @@
+      SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $           ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+     $           LIWORK, INFO )
+
+      IMPLICIT NONE
+*
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+      REAL             ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * )
+      COMPLEX            Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSTEGR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  CSTEGR is a compatability wrapper around the improved CSTEMR routine.
+*  See SSTEMR for further details.
+*
+*  One important change is that the ABSTOL parameter no longer provides any
+*  benefit and hence is no longer used.
+*
+*  Note : CSTEGR and CSTEMR work only on machines which follow
+*  IEEE-754 floating-point standard in their handling of infinities and
+*  NaNs.  Normal execution may create these exceptiona values and hence
+*  may abort due to a floating point exception in environments which
+*  do not conform to the IEEE-754 standard.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) REAL array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          Unused.  Was the absolute error tolerance for the
+*          eigenvalues/eigenvectors in previous versions.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*          Supplying N columns is always safe.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  WORK    (workspace/output) REAL array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in SLARRE,
+*                if INFO = 2X, internal error in CLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by SLARRE or
+*                CLARRV, respectively.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL TRYRAC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL CSTEMR
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+      TRYRAC = .FALSE.
+
+      CALL CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*     End of CSTEGR
+*
+      END
diff --git a/SRC/cstein.f b/SRC/cstein.f
new file mode 100644
index 00000000..6bd02117
--- /dev/null
+++ b/SRC/cstein.f
@@ -0,0 +1,376 @@
+      SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDZ, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
+     $                   IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * )
+      COMPLEX            Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSTEIN computes the eigenvectors of a real symmetric tridiagonal
+*  matrix T corresponding to specified eigenvalues, using inverse
+*  iteration.
+*
+*  The maximum number of iterations allowed for each eigenvector is
+*  specified by an internal parameter MAXITS (currently set to 5).
+*
+*  Although the eigenvectors are real, they are stored in a complex
+*  array, which may be passed to CUNMTR or CUPMTR for back
+*  transformation to the eigenvectors of a complex Hermitian matrix
+*  which was reduced to tridiagonal form.
+*
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix
+*          T, stored in elements 1 to N-1.
+*
+*  M       (input) INTEGER
+*          The number of eigenvectors to be found.  0 <= M <= N.
+*
+*  W       (input) REAL array, dimension (N)
+*          The first M elements of W contain the eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block.  ( The output array
+*          W from SSTEBZ with ORDER = 'B' is expected here. )
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The submatrix indices associated with the corresponding
+*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
+*          the first submatrix from the top, =2 if W(i) belongs to
+*          the second submatrix, etc.  ( The output array IBLOCK
+*          from SSTEBZ is expected here. )
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*          ( The output array ISPLIT from SSTEBZ is expected here. )
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, M)
+*          The computed eigenvectors.  The eigenvector associated
+*          with the eigenvalue W(i) is stored in the i-th column of
+*          Z.  Any vector which fails to converge is set to its current
+*          iterate after MAXITS iterations.
+*          The imaginary parts of the eigenvectors are set to zero.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (5*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  IFAIL   (output) INTEGER array, dimension (M)
+*          On normal exit, all elements of IFAIL are zero.
+*          If one or more eigenvectors fail to converge after
+*          MAXITS iterations, then their indices are stored in
+*          array IFAIL.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, then i eigenvectors failed to converge
+*               in MAXITS iterations.  Their indices are stored in
+*               array IFAIL.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXITS  INTEGER, default = 5
+*          The maximum number of iterations performed.
+*
+*  EXTRA   INTEGER, default = 2
+*          The number of iterations performed after norm growth
+*          criterion is satisfied, should be at least 1.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               ZERO, ONE, TEN, ODM3, ODM1
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1,
+     $                   ODM3 = 1.0E-3, ODM1 = 1.0E-1 )
+      INTEGER            MAXITS, EXTRA
+      PARAMETER          ( MAXITS = 5, EXTRA = 2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
+     $                   INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
+     $                   JBLK, JMAX, JR, NBLK, NRMCHK
+      REAL               CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
+     $                   SCL, SEP, STPCRT, TOL, XJ, XJM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 )
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SASUM, SLAMCH, SNRM2
+      EXTERNAL           ISAMAX, SASUM, SLAMCH, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CMPLX, MAX, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      DO 10 I = 1, M
+         IFAIL( I ) = 0
+   10 CONTINUE
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         DO 20 J = 2, M
+            IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
+               INFO = -6
+               GO TO 30
+            END IF
+            IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
+     $           THEN
+               INFO = -5
+               GO TO 30
+            END IF
+   20    CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSTEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      EPS = SLAMCH( 'Precision' )
+*
+*     Initialize seed for random number generator SLARNV.
+*
+      DO 40 I = 1, 4
+         ISEED( I ) = 1
+   40 CONTINUE
+*
+*     Initialize pointers.
+*
+      INDRV1 = 0
+      INDRV2 = INDRV1 + N
+      INDRV3 = INDRV2 + N
+      INDRV4 = INDRV3 + N
+      INDRV5 = INDRV4 + N
+*
+*     Compute eigenvectors of matrix blocks.
+*
+      J1 = 1
+      DO 180 NBLK = 1, IBLOCK( M )
+*
+*        Find starting and ending indices of block nblk.
+*
+         IF( NBLK.EQ.1 ) THEN
+            B1 = 1
+         ELSE
+            B1 = ISPLIT( NBLK-1 ) + 1
+         END IF
+         BN = ISPLIT( NBLK )
+         BLKSIZ = BN - B1 + 1
+         IF( BLKSIZ.EQ.1 )
+     $      GO TO 60
+         GPIND = B1
+*
+*        Compute reorthogonalization criterion and stopping criterion.
+*
+         ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
+         ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
+         DO 50 I = B1 + 1, BN - 1
+            ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
+     $               ABS( E( I ) ) )
+   50    CONTINUE
+         ORTOL = ODM3*ONENRM
+*
+         STPCRT = SQRT( ODM1 / BLKSIZ )
+*
+*        Loop through eigenvalues of block nblk.
+*
+   60    CONTINUE
+         JBLK = 0
+         DO 170 J = J1, M
+            IF( IBLOCK( J ).NE.NBLK ) THEN
+               J1 = J
+               GO TO 180
+            END IF
+            JBLK = JBLK + 1
+            XJ = W( J )
+*
+*           Skip all the work if the block size is one.
+*
+            IF( BLKSIZ.EQ.1 ) THEN
+               WORK( INDRV1+1 ) = ONE
+               GO TO 140
+            END IF
+*
+*           If eigenvalues j and j-1 are too close, add a relatively
+*           small perturbation.
+*
+            IF( JBLK.GT.1 ) THEN
+               EPS1 = ABS( EPS*XJ )
+               PERTOL = TEN*EPS1
+               SEP = XJ - XJM
+               IF( SEP.LT.PERTOL )
+     $            XJ = XJM + PERTOL
+            END IF
+*
+            ITS = 0
+            NRMCHK = 0
+*
+*           Get random starting vector.
+*
+            CALL SLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
+*
+*           Copy the matrix T so it won't be destroyed in factorization.
+*
+            CALL SCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
+            CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
+            CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
+*
+*           Compute LU factors with partial pivoting  ( PT = LU )
+*
+            TOL = ZERO
+            CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
+     $                   IINFO )
+*
+*           Update iteration count.
+*
+   70       CONTINUE
+            ITS = ITS + 1
+            IF( ITS.GT.MAXITS )
+     $         GO TO 120
+*
+*           Normalize and scale the righthand side vector Pb.
+*
+            SCL = BLKSIZ*ONENRM*MAX( EPS,
+     $            ABS( WORK( INDRV4+BLKSIZ ) ) ) /
+     $            SASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+*
+*           Solve the system LU = Pb.
+*
+            CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
+     $                   WORK( INDRV1+1 ), TOL, IINFO )
+*
+*           Reorthogonalize by modified Gram-Schmidt if eigenvalues are
+*           close enough.
+*
+            IF( JBLK.EQ.1 )
+     $         GO TO 110
+            IF( ABS( XJ-XJM ).GT.ORTOL )
+     $         GPIND = J
+            IF( GPIND.NE.J ) THEN
+               DO 100 I = GPIND, J - 1
+                  CTR = ZERO
+                  DO 80 JR = 1, BLKSIZ
+                     CTR = CTR + WORK( INDRV1+JR )*
+     $                     REAL( Z( B1-1+JR, I ) )
+   80             CONTINUE
+                  DO 90 JR = 1, BLKSIZ
+                     WORK( INDRV1+JR ) = WORK( INDRV1+JR ) -
+     $                                   CTR*REAL( Z( B1-1+JR, I ) )
+   90             CONTINUE
+  100          CONTINUE
+            END IF
+*
+*           Check the infinity norm of the iterate.
+*
+  110       CONTINUE
+            JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            NRM = ABS( WORK( INDRV1+JMAX ) )
+*
+*           Continue for additional iterations after norm reaches
+*           stopping criterion.
+*
+            IF( NRM.LT.STPCRT )
+     $         GO TO 70
+            NRMCHK = NRMCHK + 1
+            IF( NRMCHK.LT.EXTRA+1 )
+     $         GO TO 70
+*
+            GO TO 130
+*
+*           If stopping criterion was not satisfied, update info and
+*           store eigenvector number in array ifail.
+*
+  120       CONTINUE
+            INFO = INFO + 1
+            IFAIL( INFO ) = J
+*
+*           Accept iterate as jth eigenvector.
+*
+  130       CONTINUE
+            SCL = ONE / SNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            IF( WORK( INDRV1+JMAX ).LT.ZERO )
+     $         SCL = -SCL
+            CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+  140       CONTINUE
+            DO 150 I = 1, N
+               Z( I, J ) = CZERO
+  150       CONTINUE
+            DO 160 I = 1, BLKSIZ
+               Z( B1+I-1, J ) = CMPLX( WORK( INDRV1+I ), ZERO )
+  160       CONTINUE
+*
+*           Save the shift to check eigenvalue spacing at next
+*           iteration.
+*
+            XJM = XJ
+*
+  170    CONTINUE
+  180 CONTINUE
+*
+      RETURN
+*
+*     End of CSTEIN
+*
+      END
diff --git a/SRC/cstemr.f b/SRC/cstemr.f
new file mode 100644
index 00000000..ddb2e0c9
--- /dev/null
+++ b/SRC/cstemr.f
@@ -0,0 +1,663 @@
+      SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      LOGICAL            TRYRAC
+      INTEGER            IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
+      REAL             VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * )
+      COMPLEX            Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSTEMR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  Depending on the number of desired eigenvalues, these are computed either
+*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
+*  computed by the use of various suitable L D L^T factorizations near clusters
+*  of close eigenvalues (referred to as RRRs, Relatively Robust
+*  Representations). An informal sketch of the algorithm follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  For more details, see:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*  Notes:
+*  1.CSTEMR works only on machines which follow IEEE-754
+*  floating-point standard in their handling of infinities and NaNs.
+*  This permits the use of efficient inner loops avoiding a check for
+*  zero divisors.
+*
+*  2. LAPACK routines can be used to reduce a complex Hermitean matrix to
+*  real symmetric tridiagonal form.
+*
+*  (Any complex Hermitean tridiagonal matrix has real values on its diagonal
+*  and potentially complex numbers on its off-diagonals. By applying a
+*  similarity transform with an appropriate diagonal matrix
+*  diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
+*  matrix can be transformed into a real symmetric matrix and complex
+*  arithmetic can be entirely avoided.)
+*
+*  While the eigenvectors of the real symmetric tridiagonal matrix are real,
+*  the eigenvectors of original complex Hermitean matrix have complex entries
+*  in general.
+*  Since LAPACK drivers overwrite the matrix data with the eigenvectors,
+*  CSTEMR accepts complex workspace to facilitate interoperability
+*  with CUNMTR or CUPMTR.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) REAL array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and can be computed with a workspace
+*          query by setting NZC = -1, see below.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  NZC     (input) INTEGER
+*          The number of eigenvectors to be held in the array Z.
+*          If RANGE = 'A', then NZC >= max(1,N).
+*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+*          If RANGE = 'I', then NZC >= IU-IL+1.
+*          If NZC = -1, then a workspace query is assumed; the
+*          routine calculates the number of columns of the array Z that
+*          are needed to hold the eigenvectors.
+*          This value is returned as the first entry of the Z array, and
+*          no error message related to NZC is issued by XERBLA.
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  TRYRAC  (input/output) LOGICAL
+*          If TRYRAC.EQ..TRUE., indicates that the code should check whether
+*          the tridiagonal matrix defines its eigenvalues to high relative
+*          accuracy.  If so, the code uses relative-accuracy preserving
+*          algorithms that might be (a bit) slower depending on the matrix.
+*          If the matrix does not define its eigenvalues to high relative
+*          accuracy, the code can uses possibly faster algorithms.
+*          If TRYRAC.EQ..FALSE., the code is not required to guarantee
+*          relatively accurate eigenvalues and can use the fastest possible
+*          techniques.
+*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
+*          does not define its eigenvalues to high relative accuracy.
+*
+*  WORK    (workspace/output) REAL array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in SLARRE,
+*                if INFO = 2X, internal error in CLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by SLARRE or
+*                CLARRV, respectively.
+*
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, FOUR, MINRGP
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
+     $                     FOUR = 4.0E0,
+     $                     MINRGP = 3.0E-3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+      INTEGER            I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
+     $                   IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
+     $                   INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
+     $                   ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
+     $                   NZCMIN, OFFSET, WBEGIN, WEND
+      REAL               BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
+     $                   RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
+     $                   THRESH, TMP, TNRM, WL, WU
+*     ..
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARRV, CSWAP, SCOPY, SLAE2, SLAEV2, SLARRC,
+     $                   SLARRE, SLARRJ, SLARRR, SLASRT, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+
+
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+      ZQUERY = ( NZC.EQ.-1 )
+
+*     SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
+*     In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
+*     Furthermore, CLARRV needs WORK of size 12*N, IWORK of size 7*N.
+      IF( WANTZ ) THEN
+         LWMIN = 18*N
+         LIWMIN = 10*N
+      ELSE
+*        need less workspace if only the eigenvalues are wanted
+         LWMIN = 12*N
+         LIWMIN = 8*N
+      ENDIF
+
+      WL = ZERO
+      WU = ZERO
+      IIL = 0
+      IIU = 0
+
+      IF( VALEIG ) THEN
+*        We do not reference VL, VU in the cases RANGE = 'I','A'
+*        The interval (WL, WU] contains all the wanted eigenvalues.
+*        It is either given by the user or computed in SLARRE.
+         WL = VL
+         WU = VU
+      ELSEIF( INDEIG ) THEN
+*        We do not reference IL, IU in the cases RANGE = 'V','A'
+         IIL = IL
+         IIU = IU
+      ENDIF
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
+         INFO = -7
+      ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
+         INFO = -8
+      ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -17
+      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -19
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( WANTZ .AND. ALLEIG ) THEN
+            NZCMIN = N
+         ELSE IF( WANTZ .AND. VALEIG ) THEN
+            CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+     $                            NZCMIN, ITMP, ITMP2, INFO )
+         ELSE IF( WANTZ .AND. INDEIG ) THEN
+            NZCMIN = IIU-IIL+1
+         ELSE
+*           WANTZ .EQ. FALSE.
+            NZCMIN = 0
+         ENDIF
+         IF( ZQUERY .AND. INFO.EQ.0 ) THEN
+            Z( 1,1 ) = NZCMIN
+         ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
+            INFO = -14
+         END IF
+      END IF
+
+      IF( INFO.NE.0 ) THEN
+*
+         CALL XERBLA( 'CSTEMR', -INFO )
+*
+         RETURN
+      ELSE IF( LQUERY .OR. ZQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Handle N = 0, 1, and 2 cases immediately
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            Z( 1, 1 ) = ONE
+            ISUPPZ(1) = 1
+            ISUPPZ(2) = 1
+         END IF
+         RETURN
+      END IF
+*
+      IF( N.EQ.2 ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL SLAE2( D(1), E(1), D(2), R1, R2 )
+         ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            CALL SLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
+         END IF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R2.GT.WL).AND.
+     $                  (R2.LE.WU)).OR.
+     $      (INDEIG.AND.(IIL.EQ.1)) ) THEN
+            M = M+1
+            W( M ) = R2
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = -SN
+               Z( 2, M ) = CS
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R1.GT.WL).AND.
+     $                  (R1.LE.WU)).OR.
+     $      (INDEIG.AND.(IIU.EQ.2)) ) THEN
+            M = M+1
+            W( M ) = R1
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = CS
+               Z( 2, M ) = SN
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         RETURN
+      END IF
+
+*     Continue with general N
+
+      INDGRS = 1
+      INDERR = 2*N + 1
+      INDGP = 3*N + 1
+      INDD = 4*N + 1
+      INDE2 = 5*N + 1
+      INDWRK = 6*N + 1
+*
+      IINSPL = 1
+      IINDBL = N + 1
+      IINDW = 2*N + 1
+      IINDWK = 3*N + 1
+*
+*     Scale matrix to allowable range, if necessary.
+*     The allowable range is related to the PIVMIN parameter; see the
+*     comments in SLARRD.  The preference for scaling small values
+*     up is heuristic; we expect users' matrices not to be close to the
+*     RMAX threshold.
+*
+      SCALE = ONE
+      TNRM = SLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         SCALE = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         SCALE = RMAX / TNRM
+      END IF
+      IF( SCALE.NE.ONE ) THEN
+         CALL SSCAL( N, SCALE, D, 1 )
+         CALL SSCAL( N-1, SCALE, E, 1 )
+         TNRM = TNRM*SCALE
+         IF( VALEIG ) THEN
+*           If eigenvalues in interval have to be found,
+*           scale (WL, WU] accordingly
+            WL = WL*SCALE
+            WU = WU*SCALE
+         ENDIF
+      END IF
+*
+*     Compute the desired eigenvalues of the tridiagonal after splitting
+*     into smaller subblocks if the corresponding off-diagonal elements
+*     are small
+*     THRESH is the splitting parameter for SLARRE
+*     A negative THRESH forces the old splitting criterion based on the
+*     size of the off-diagonal. A positive THRESH switches to splitting
+*     which preserves relative accuracy.
+*
+      IF( TRYRAC ) THEN
+*        Test whether the matrix warrants the more expensive relative approach.
+         CALL SLARRR( N, D, E, IINFO )
+      ELSE
+*        The user does not care about relative accurately eigenvalues
+         IINFO = -1
+      ENDIF
+*     Set the splitting criterion
+      IF (IINFO.EQ.0) THEN
+         THRESH = EPS
+      ELSE
+         THRESH = -EPS
+*        relative accuracy is desired but T does not guarantee it
+         TRYRAC = .FALSE.
+      ENDIF
+*
+      IF( TRYRAC ) THEN
+*        Copy original diagonal, needed to guarantee relative accuracy
+         CALL SCOPY(N,D,1,WORK(INDD),1)
+      ENDIF
+*     Store the squares of the offdiagonal values of T
+      DO 5 J = 1, N-1
+         WORK( INDE2+J-1 ) = E(J)**2
+ 5    CONTINUE
+
+*     Set the tolerance parameters for bisection
+      IF( .NOT.WANTZ ) THEN
+*        SLARRE computes the eigenvalues to full precision.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ELSE
+*        SLARRE computes the eigenvalues to less than full precision.
+*        CLARRV will refine the eigenvalue approximations, and we only
+*        need less accurate initial bisection in SLARRE.
+*        Note: these settings do only affect the subset case and SLARRE
+         RTOL1 = MAX( SQRT(EPS)*5.0E-2, FOUR * EPS )
+         RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
+      ENDIF
+      CALL SLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
+     $             WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+     $             IWORK( IINSPL ), M, W, WORK( INDERR ),
+     $             WORK( INDGP ), IWORK( IINDBL ),
+     $             IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+     $             WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = 10 + ABS( IINFO )
+         RETURN
+      END IF
+*     Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired
+*     part of the spectrum. All desired eigenvalues are contained in
+*     (WL,WU]
+
+
+      IF( WANTZ ) THEN
+*
+*        Compute the desired eigenvectors corresponding to the computed
+*        eigenvalues
+*
+         CALL CLARRV( N, WL, WU, D, E,
+     $                PIVMIN, IWORK( IINSPL ), M,
+     $                1, M, MINRGP, RTOL1, RTOL2,
+     $                W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+     $                IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
+     $                ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = 20 + ABS( IINFO )
+            RETURN
+         END IF
+      ELSE
+*        SLARRE computes eigenvalues of the (shifted) root representation
+*        CLARRV returns the eigenvalues of the unshifted matrix.
+*        However, if the eigenvectors are not desired by the user, we need
+*        to apply the corresponding shifts from SLARRE to obtain the
+*        eigenvalues of the original matrix.
+         DO 20 J = 1, M
+            ITMP = IWORK( IINDBL+J-1 )
+            W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 20      CONTINUE
+      END IF
+*
+
+      IF ( TRYRAC ) THEN
+*        Refine computed eigenvalues so that they are relatively accurate
+*        with respect to the original matrix T.
+         IBEGIN = 1
+         WBEGIN = 1
+         DO 39  JBLK = 1, IWORK( IINDBL+M-1 )
+            IEND = IWORK( IINSPL+JBLK-1 )
+            IN = IEND - IBEGIN + 1
+            WEND = WBEGIN - 1
+*           check if any eigenvalues have to be refined in this block
+ 36         CONTINUE
+            IF( WEND.LT.M ) THEN
+               IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
+                  WEND = WEND + 1
+                  GO TO 36
+               END IF
+            END IF
+            IF( WEND.LT.WBEGIN ) THEN
+               IBEGIN = IEND + 1
+               GO TO 39
+            END IF
+
+            OFFSET = IWORK(IINDW+WBEGIN-1)-1
+            IFIRST = IWORK(IINDW+WBEGIN-1)
+            ILAST = IWORK(IINDW+WEND-1)
+            RTOL2 = FOUR * EPS
+            CALL SLARRJ( IN,
+     $                   WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
+     $                   IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
+     $                   WORK( INDERR+WBEGIN-1 ),
+     $                   WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
+     $                   TNRM, IINFO )
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+ 39      CONTINUE
+      ENDIF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( SCALE.NE.ONE ) THEN
+         CALL SSCAL( M, ONE / SCALE, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in increasing order, then sort them,
+*     possibly along with eigenvectors.
+*
+      IF( NSPLIT.GT.1 ) THEN
+         IF( .NOT. WANTZ ) THEN
+            CALL SLASRT( 'I', M, W, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = 3
+               RETURN
+            END IF
+         ELSE
+            DO 60 J = 1, M - 1
+               I = 0
+               TMP = W( J )
+               DO 50 JJ = J + 1, M
+                  IF( W( JJ ).LT.TMP ) THEN
+                     I = JJ
+                     TMP = W( JJ )
+                  END IF
+ 50            CONTINUE
+               IF( I.NE.0 ) THEN
+                  W( I ) = W( J )
+                  W( J ) = TMP
+                  IF( WANTZ ) THEN
+                     CALL CSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+                     ITMP = ISUPPZ( 2*I-1 )
+                     ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
+                     ISUPPZ( 2*J-1 ) = ITMP
+                     ITMP = ISUPPZ( 2*I )
+                     ISUPPZ( 2*I ) = ISUPPZ( 2*J )
+                     ISUPPZ( 2*J ) = ITMP
+                  END IF
+               END IF
+ 60         CONTINUE
+         END IF
+      ENDIF
+*
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of CSTEMR
+*
+      END
diff --git a/SRC/csteqr.f b/SRC/csteqr.f
new file mode 100644
index 00000000..6e130ea2
--- /dev/null
+++ b/SRC/csteqr.f
@@ -0,0 +1,503 @@
+      SUBROUTINE CSTEQR( 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 ..
+      REAL               D( * ), E( * ), WORK( * )
+      COMPLEX            Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSTEQR 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 CHETRD or CHPTRD or CHBTRD 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) REAL 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) REAL 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 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) REAL 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 ..
+      REAL               ZERO, ONE, TWO, THREE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   THREE = 3.0E0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
+     $                   CONE = ( 1.0E0, 0.0E0 ) )
+      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
+      REAL               ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
+     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST, SLAPY2
+      EXTERNAL           LSAME, SLAMCH, SLANST, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLASET, CLASR, CSWAP, SLAE2, SLAEV2, SLARTG,
+     $                   SLASCL, SLASRT, 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( 'CSTEQR', -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 = SLAMCH( 'E' )
+      EPS2 = EPS**2
+      SAFMIN = SLAMCH( '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 CLASET( '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 = SLANST( '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 SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+     $                INFO )
+      ELSE IF( ANORM.LT.SSFMIN ) THEN
+         ISCALE = 2
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL SLASCL( '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 SLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L+1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
+               WORK( L ) = C
+               WORK( N-1+L ) = S
+               CALL CLASR( 'R', 'V', 'B', N, 2, WORK( L ),
+     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
+            ELSE
+               CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 CLASR( '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 SLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L-1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
+               WORK( M ) = C
+               WORK( N-1+M ) = S
+               CALL CLASR( 'R', 'V', 'F', N, 2, WORK( M ),
+     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
+            ELSE
+               CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 CLASR( '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 SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
+     $                N, INFO )
+      ELSE IF( ISCALE.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL SLASCL( '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 SLASRT( '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 CSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+            END IF
+  180    CONTINUE
+      END IF
+      RETURN
+*
+*     End of CSTEQR
+*
+      END
diff --git a/SRC/csycon.f b/SRC/csycon.f
new file mode 100644
index 00000000..0453c894
--- /dev/null
+++ b/SRC/csycon.f
@@ -0,0 +1,163 @@
+      SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex symmetric matrix A using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by CSYTRF.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CSYTRF.
+*
+*  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 CSYTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          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) COMPLEX array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, KASE
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CSYTRS, 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( 'CSYCON', -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 CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL CSYTRS( 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 CSYCON
+*
+      END
diff --git a/SRC/csymv.f b/SRC/csymv.f
new file mode 100644
index 00000000..e08240fe
--- /dev/null
+++ b/SRC/csymv.f
@@ -0,0 +1,264 @@
+      SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INCX, INCY, LDA, N
+      COMPLEX            ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYMV  performs the matrix-vector  operation
+*
+*     y := alpha*A*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are n element vectors and
+*  A is an n by n symmetric matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A        (input) COMPLEX array, dimension ( LDA, N )
+*           Before entry, with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced.
+*           Before entry, with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced.
+*           Unchanged on exit.
+*
+*  LDA      (input) INTEGER
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, N ).
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA     (input) COMPLEX
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y        (input/output) COMPLEX array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y. On exit, Y is overwritten by the updated
+*           vector y.
+*
+*  INCY     (input) INTEGER
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
+      COMPLEX            TEMP1, TEMP2
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = 5
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 7
+      ELSE IF( INCY.EQ.0 ) THEN
+         INFO = 10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSYMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     Set up the start points in  X  and  Y.
+*
+      IF( INCX.GT.0 ) THEN
+         KX = 1
+      ELSE
+         KX = 1 - ( N-1 )*INCX
+      END IF
+      IF( INCY.GT.0 ) THEN
+         KY = 1
+      ELSE
+         KY = 1 - ( N-1 )*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+*     First form  y := beta*y.
+*
+      IF( BETA.NE.ONE ) THEN
+         IF( INCY.EQ.1 ) THEN
+            IF( BETA.EQ.ZERO ) THEN
+               DO 10 I = 1, N
+                  Y( I ) = ZERO
+   10          CONTINUE
+            ELSE
+               DO 20 I = 1, N
+                  Y( I ) = BETA*Y( I )
+   20          CONTINUE
+            END IF
+         ELSE
+            IY = KY
+            IF( BETA.EQ.ZERO ) THEN
+               DO 30 I = 1, N
+                  Y( IY ) = ZERO
+                  IY = IY + INCY
+   30          CONTINUE
+            ELSE
+               DO 40 I = 1, N
+                  Y( IY ) = BETA*Y( IY )
+                  IY = IY + INCY
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      IF( ALPHA.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  y  when A is stored in upper triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 60 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               DO 50 I = 1, J - 1
+                  Y( I ) = Y( I ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( I )
+   50          CONTINUE
+               Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2
+   60       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 80 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               IX = KX
+               IY = KY
+               DO 70 I = 1, J - 1
+                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( IX )
+                  IX = IX + INCX
+                  IY = IY + INCY
+   70          CONTINUE
+               Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+   80       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  y  when A is stored in lower triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 100 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               Y( J ) = Y( J ) + TEMP1*A( J, J )
+               DO 90 I = J + 1, N
+                  Y( I ) = Y( I ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( I )
+   90          CONTINUE
+               Y( J ) = Y( J ) + ALPHA*TEMP2
+  100       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 120 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               Y( JY ) = Y( JY ) + TEMP1*A( J, J )
+               IX = JX
+               IY = JY
+               DO 110 I = J + 1, N
+                  IX = IX + INCX
+                  IY = IY + INCY
+                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( IX )
+  110          CONTINUE
+               Y( JY ) = Y( JY ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+  120       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CSYMV
+*
+      END
diff --git a/SRC/csyr.f b/SRC/csyr.f
new file mode 100644
index 00000000..70aced04
--- /dev/null
+++ b/SRC/csyr.f
@@ -0,0 +1,198 @@
+      SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, 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            INCX, LDA, N
+      COMPLEX            ALPHA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYR   performs the symmetric rank 1 operation
+*
+*     A := alpha*x*( x' ) + A,
+*
+*  where alpha is a complex scalar, x is an n element vector and A is an
+*  n by n symmetric matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  A        (input/output) COMPLEX array, dimension ( LDA, N )
+*           Before entry, with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced. On exit, the
+*           upper triangular part of the array A is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry, with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced. On exit, the
+*           lower triangular part of the array A is overwritten by the
+*           lower triangular part of the updated matrix.
+*
+*  LDA      (input) INTEGER
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, N ).
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, J, JX, KX
+      COMPLEX            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( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = 7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSYR  ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Set the start point in X if the increment is not unity.
+*
+      IF( INCX.LE.0 ) THEN
+         KX = 1 - ( N-1 )*INCX
+      ELSE IF( INCX.NE.1 ) THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  A  when A is stored in upper triangle.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 20 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  DO 10 I = 1, J
+                     A( I, J ) = A( I, J ) + X( I )*TEMP
+   10             CONTINUE
+               END IF
+   20       CONTINUE
+         ELSE
+            JX = KX
+            DO 40 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  IX = KX
+                  DO 30 I = 1, J
+                     A( I, J ) = A( I, J ) + X( IX )*TEMP
+                     IX = IX + INCX
+   30             CONTINUE
+               END IF
+               JX = JX + INCX
+   40       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  A  when A is stored in lower triangle.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 60 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  DO 50 I = J, N
+                     A( I, J ) = A( I, J ) + X( I )*TEMP
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE
+            JX = KX
+            DO 80 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  IX = JX
+                  DO 70 I = J, N
+                     A( I, J ) = A( I, J ) + X( IX )*TEMP
+                     IX = IX + INCX
+   70             CONTINUE
+               END IF
+               JX = JX + INCX
+   80       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CSYR
+*
+      END
diff --git a/SRC/csyrfs.f b/SRC/csyrfs.f
new file mode 100644
index 00000000..c0970d1e
--- /dev/null
+++ b/SRC/csyrfs.f
@@ -0,0 +1,343 @@
+      SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite, and
+*  provides error bounds and backward error estimates for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX 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(1,N).
+*
+*  AF      (input) COMPLEX array, dimension (LDAF,N)
+*          The factored form of the matrix A.  AF contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by CSYTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by CSYTRF.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by CSYTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CLACN2, CSYMV, CSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSYRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL CCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL CSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + CABS1( A( K, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + CABS1( A( K, K ) )*XK
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 CSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            CALL CAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL CSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL CSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of CSYRFS
+*
+      END
diff --git a/SRC/csysv.f b/SRC/csysv.f
new file mode 100644
index 00000000..132256b9
--- /dev/null
+++ b/SRC/csysv.f
@@ -0,0 +1,174 @@
+      SUBROUTINE CSYSV( 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( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYSV computes the solution to a complex 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) COMPLEX 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
+*          CSYTRF.
+*
+*  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 CSYTRF.  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) COMPLEX 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) COMPLEX 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
+*          CSYTRF.
+*
+*          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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSYTRF, CSYTRS, 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, 'CSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSYSV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CSYSV
+*
+      END
diff --git a/SRC/csysvx.f b/SRC/csysvx.f
new file mode 100644
index 00000000..a1dc1505
--- /dev/null
+++ b/SRC/csysvx.f
@@ -0,0 +1,300 @@
+      SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+     $                   LDB, X, LDX, RCOND, FERR, BERR, 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          FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYSVX uses the diagonal pivoting factorization to compute the
+*  solution to a complex system of linear equations A * X = B,
+*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.
+*     The form of the factorization is
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices, and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AF and IPIV contain the factored form
+*                  of A.  A, AF and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX 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(1,N).
+*
+*  AF      (input or output) COMPLEX array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by CSYTRF.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T.
+*
+*  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 details of the interchanges and the block structure
+*          of D, as determined by CSYTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by CSYTRF.
+*
+*  B       (input) COMPLEX array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= max(1,2*N), and for best
+*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
+*          NB is the optimal blocksize for CSYTRF.
+*
+*          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) REAL 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:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOFACT
+      INTEGER            LWKOPT, NB
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               CLANSY, SLAMCH
+      EXTERNAL           ILAENV, LSAME, CLANSY, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACPY, CSYCON, CSYRFS, CSYTRF, CSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKOPT = MAX( 1, 2*N )
+         IF( NOFACT ) THEN
+            NB = ILAENV( 1, 'CSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = MAX( LWKOPT, N*NB )
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSYSVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL CLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL CSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = CLANSY( 'I', UPLO, N, A, LDA, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL CSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL CSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CSYSVX
+*
+      END
diff --git a/SRC/csytf2.f b/SRC/csytf2.f
new file mode 100644
index 00000000..50f24ee6
--- /dev/null
+++ b/SRC/csytf2.f
@@ -0,0 +1,522 @@
+      SUBROUTINE CSYTF2( 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( * )
+      COMPLEX            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYTF2 computes the factorization of a complex 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) COMPLEX 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.209 and l.377
+*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*    by
+*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+      COMPLEX            CONE
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
+      REAL               ABSAKK, ALPHA, COLMAX, ROWMAX
+      COMPLEX            D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, SISNAN
+      INTEGER            ICAMAX
+      EXTERNAL           LSAME, ICAMAX, SISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSCAL, CSWAP, CSYR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL, SQRT
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+*     ..
+*     .. 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( 'CSYTF2', -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 = CABS1( 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 = ICAMAX( K-1, A( 1, K ), 1 )
+            COLMAX = CABS1( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN
+*
+*           Column K is zero or 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 + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+               CALL CSWAP( 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 = CONE / A( K, K )
+               CALL CSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+*              Store U(k) in column k
+*
+               CALL CSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 = CABS1( 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 + ICAMAX( N-K, A( K+1, K ), 1 )
+            COLMAX = CABS1( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO .OR. SISNAN(ABSAKK) ) THEN
+*
+*           Column K is zero or 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 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+               CALL CSWAP( 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)'
+*
+                  R1 = CONE / A( K, K )
+                  CALL CSYR( UPLO, N-K, -R1, A( K+1, K ), 1,
+     $                       A( K+1, K+1 ), LDA )
+*
+*                 Store L(k) in column K
+*
+                  CALL CSCAL( N-K, R1, 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 - ( 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) )'
+*
+*                 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 = CONE / ( D11*D22-CONE )
+                  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 CSYTF2
+*
+      END
diff --git a/SRC/csytrf.f b/SRC/csytrf.f
new file mode 100644
index 00000000..68cb52c9
--- /dev/null
+++ b/SRC/csytrf.f
@@ -0,0 +1,286 @@
+      SUBROUTINE CSYTRF( 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( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYTRF computes the factorization of a complex 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
+*  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) COMPLEX 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) COMPLEX 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           CLASYF, CSYTF2, 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, 'CSYTRF', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CSYTRF', -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, 'CSYTRF', 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 CLASYF;
+*        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 CLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns 1:k of A
+*
+            CALL CSYTF2( 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 CLASYF;
+*        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 CLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+     $                   WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns k:n of A
+*
+            CALL CSYTF2( 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 CSYTRF
+*
+      END
diff --git a/SRC/csytri.f b/SRC/csytri.f
new file mode 100644
index 00000000..7b246387
--- /dev/null
+++ b/SRC/csytri.f
@@ -0,0 +1,313 @@
+      SUBROUTINE CSYTRI( 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( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYTRI computes the inverse of a complex symmetric indefinite matrix
+*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by
+*  CSYTRF.
+*
+*  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) COMPLEX 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 CSYTRF.
+*
+*          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 CSYTRF.
+*
+*  WORK    (workspace) COMPLEX 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, D(i,i) = 0; the matrix is singular and its
+*               inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KP, KSTEP
+      COMPLEX            AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX            CDOTU
+      EXTERNAL           LSAME, CDOTU
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CSWAP, CSYMV, 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( 'CSYTRI', -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 CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL CSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = 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 CCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL CSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - CDOTU( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+               A( K, K+1 ) = A( K, K+1 ) -
+     $                       CDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+               CALL CCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+               CALL CSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K+1 ), 1 )
+               A( K+1, K+1 ) = A( K+1, K+1 ) -
+     $                         CDOTU( 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 CSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+            CALL CSWAP( 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 CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL CSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = 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 CCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL CSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - CDOTU( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+               A( K, K-1 ) = A( K, K-1 ) -
+     $                       CDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+     $                       1 )
+               CALL CCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+               CALL CSYMV( 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 ) -
+     $                         CDOTU( 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 CSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+            CALL CSWAP( 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 CSYTRI
+*
+      END
diff --git a/SRC/csytrs.f b/SRC/csytrs.f
new file mode 100644
index 00000000..ba084142
--- /dev/null
+++ b/SRC/csytrs.f
@@ -0,0 +1,369 @@
+      SUBROUTINE CSYTRS( 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( * )
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CSYTRS solves a system of linear equations A*X = B with a complex
+*  symmetric matrix A using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by CSYTRF.
+*
+*  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) COMPLEX array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by CSYTRF.
+*
+*  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 CSYTRF.
+*
+*  B       (input/output) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KP
+      COMPLEX            AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CGERU, CSCAL, CSWAP, 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( 'CSYTRS', -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 CSWAP( 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 CGERU( 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 CSCAL( 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 CSWAP( 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 CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL CGERU( 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 CGEMV( '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 CSWAP( 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 CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL CGEMV( '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 CSWAP( 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 CSWAP( 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 CGERU( 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 CSCAL( 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 CSWAP( 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 CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL CGERU( 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 CGEMV( '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 CSWAP( 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 CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL CGEMV( '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 CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CSYTRS
+*
+      END
diff --git a/SRC/ctbcon.f b/SRC/ctbcon.f
new file mode 100644
index 00000000..52efe890
--- /dev/null
+++ b/SRC/ctbcon.f
@@ -0,0 +1,209 @@
+      SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
+     $                   RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, KD, LDAB, N
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTBCON estimates the reciprocal of the condition number of a
+*  triangular band matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  RCOND   (output) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               CLANTB, SLAMCH
+      EXTERNAL           LSAME, ICAMAX, CLANTB, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATBS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( N, 1 ) )
+*
+*     Compute the 1-norm of the triangular matrix A or A'.
+*
+      ANORM = CLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, RWORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the 1-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 CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL CLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
+     $                      AB, LDAB, WORK, SCALE, RWORK, INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL CLATBS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
+     $                      N, KD, AB, LDAB, WORK, SCALE, RWORK, INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = ICAMAX( N, WORK, 1 )
+               XNORM = CABS1( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL CSRSCL( 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 CTBCON
+*
+      END
diff --git a/SRC/ctbrfs.f b/SRC/ctbrfs.f
new file mode 100644
index 00000000..e861416b
--- /dev/null
+++ b/SRC/ctbrfs.f
@@ -0,0 +1,397 @@
+      SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
+     $                   LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, KD, LDAB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AB( LDAB, * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTBRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular band
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by CTBTRS or some other
+*  means before entering this routine.  CTBRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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)
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          The solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANSN, TRANST
+      INTEGER            I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CLACN2, CTBMV, CTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, MIN, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = KD + 2
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL CCOPY( N, X( 1, J ), 1, WORK, 1 )
+         CALL CTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
+         CALL CAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 30 I = MAX( 1, K-KD ), K
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( KD+1+I-K, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 50 I = MAX( 1, K-KD ), K - 1
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( KD+1+I-K, K ) )*XK
+   50                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 70 I = K, MIN( N, K+KD )
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( 1+I-K, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 90 I = K + 1, MIN( N, K+KD )
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( 1+I-K, K ) )*XK
+   90                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A**H)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = MAX( 1, K-KD ), K
+                        S = S + CABS1( AB( KD+1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  110                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 130 I = MAX( 1, K-KD ), K - 1
+                        S = S + CABS1( AB( KD+1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  130                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, MIN( N, K+KD )
+                        S = S + CABS1( AB( 1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  150                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 170 I = K + 1, MIN( N, K+KD )
+                        S = S + CABS1( AB( 1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  170                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL CTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB, WORK,
+     $                     1 )
+               DO 220 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  230          CONTINUE
+               CALL CTBSV( UPLO, TRANSN, DIAG, N, KD, AB, LDAB, WORK,
+     $                     1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of CTBRFS
+*
+      END
diff --git a/SRC/ctbtrs.f b/SRC/ctbtrs.f
new file mode 100644
index 00000000..da333e47
--- /dev/null
+++ b/SRC/ctbtrs.f
@@ -0,0 +1,162 @@
+      SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTBTRS solves a triangular system of the form
+*
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*
+*  where A is a triangular band matrix of order N, and B is an
+*  N-by-NRHS matrix.  A check is made to verify that A is nonsingular.
+*
+*  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)
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) COMPLEX 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 ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOUNIT = LSAME( DIAG, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            DO 10 INFO = 1, N
+               IF( AB( KD+1, INFO ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            DO 20 INFO = 1, N
+               IF( AB( 1, INFO ).EQ.ZERO )
+     $            RETURN
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve A * X = B,  A**T * X = B,  or  A**H * X = B.
+*
+      DO 30 J = 1, NRHS
+         CALL CTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of CTBTRS
+*
+      END
diff --git a/SRC/ctgevc.f b/SRC/ctgevc.f
new file mode 100644
index 00000000..0f98a65f
--- /dev/null
+++ b/SRC/ctgevc.f
@@ -0,0 +1,633 @@
+      SUBROUTINE CTGEVC( 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( * )
+      REAL               RWORK( * )
+      COMPLEX            P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*
+*  Purpose
+*  =======
+*
+*  CTGEVC 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 CGGHRD + CHGEQZ.
+*  
+*  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 array, dimension (LDS,N)
+*          The upper triangular matrix S from a generalized Schur
+*          factorization, as computed by CHGEQZ.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of array S.  LDS >= max(1,N).
+*
+*  P       (input) COMPLEX array, dimension (LDP,N)
+*          The upper triangular matrix P from a generalized Schur
+*          factorization, as computed by CHGEQZ.  P must have real
+*          diagonal elements.
+*
+*  LDP     (input) INTEGER
+*          The leading dimension of array P.  LDP >= max(1,N).
+*
+*  VL      (input/output) COMPLEX 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 CHGEQZ).
+*          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 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 CHGEQZ).
+*          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 array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
+     $                   LSA, LSB
+      INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
+     $                   J, JE, JR
+      REAL               ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
+     $                   BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
+     $                   SCALE, SMALL, TEMP, ULP, XMAX
+      COMPLEX            BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      COMPLEX            CLADIV
+      EXTERNAL           LSAME, SLAMCH, CLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, SLABAD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( 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( 'CTGEVC', -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( AIMAG( 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( 'CTGEVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = IM
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Machine Constants
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      BIG = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, BIG )
+      ULP = SLAMCH( 'Epsilon' )*SLAMCH( '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( REAL( 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( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN )
+               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
+               SBETA = ( TEMP*REAL( 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 + CONJG( S( JR, J ) )*WORK( JR )
+                     SUMB = SUMB + CONJG( P( JR, J ) )*WORK( JR )
+   80             CONTINUE
+                  SUM = ACOEFF*SUMA - CONJG( BCOEFF )*SUMB
+*
+*                 Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
+*
+*                 with scaling and perturbation of the denominator
+*
+                  D = CONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
+                  IF( ABS1( D ).LE.DMIN )
+     $               D = CMPLX( 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 ) = CLADIV( -SUM, D )
+                  XMAX = MAX( XMAX, ABS1( WORK( J ) ) )
+  100          CONTINUE
+*
+*              Back transform eigenvector if HOWMNY='B'.
+*
+               IF( ILBACK ) THEN
+                  CALL CGEMV( '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( REAL( 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( REAL( P( JE, JE ) ) )*BSCALE, SAFMIN )
+               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
+               SBETA = ( TEMP*REAL( 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 = CMPLX( 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 ) = CLADIV( -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 CGEMV( '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 CTGEVC
+*
+      END
diff --git a/SRC/ctgex2.f b/SRC/ctgex2.f
new file mode 100644
index 00000000..53726c63
--- /dev/null
+++ b/SRC/ctgex2.f
@@ -0,0 +1,261 @@
+      SUBROUTINE CTGEX2( 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            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGEX2 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 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 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 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 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            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+      REAL               TEN
+      PARAMETER          ( TEN = 10.0E+0 )
+      INTEGER            LDST
+      PARAMETER          ( LDST = 2 )
+      LOGICAL            WANDS
+      PARAMETER          ( WANDS = .TRUE. )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            STRONG, WEAK
+      INTEGER            I, M
+      REAL               CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM,
+     $                   THRESH, WS
+      COMPLEX            CDUM, F, G, SQ, SZ
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            S( LDST, LDST ), T( LDST, LDST ), WORK( 8 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACPY, CLARTG, CLASSQ, CROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      M = LDST
+      WEAK = .FALSE.
+      STRONG = .FALSE.
+*
+*     Make a local copy of selected block in (A, B)
+*
+      CALL CLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
+      CALL CLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
+*
+*     Compute the threshold for testing the acceptance of swapping.
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      SCALE = REAL( CZERO )
+      SUM = REAL( CONE )
+      CALL CLACPY( 'Full', M, M, S, LDST, WORK, M )
+      CALL CLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
+      CALL CLASSQ( 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 CLARTG( G, F, CZ, SZ, CDUM )
+      SZ = -SZ
+      CALL CROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, CONJG( SZ ) )
+      CALL CROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, CONJG( SZ ) )
+      IF( SA.GE.SB ) THEN
+         CALL CLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM )
+      ELSE
+         CALL CLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM )
+      END IF
+      CALL CROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ )
+      CALL CROT( 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 CLACPY( 'Full', M, M, S, LDST, WORK, M )
+         CALL CLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
+         CALL CROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -CONJG( SZ ) )
+         CALL CROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ, -CONJG( SZ ) )
+         CALL CROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ )
+         CALL CROT( 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 = REAL( CZERO )
+         SUM = REAL( CONE )
+         CALL CLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
+         SS = SCALE*SQRT( SUM )
+         STRONG = SS.LE.THRESH
+         IF( .NOT.STRONG )
+     $      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 CROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ, CONJG( SZ ) )
+      CALL CROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ, CONJG( SZ ) )
+      CALL CROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ, SQ )
+      CALL CROT( 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 CROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ, CONJG( SZ ) )
+      IF( WANTQ )
+     $   CALL CROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ, CONJG( 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 CTGEX2
+*
+      END
diff --git a/SRC/ctgexc.f b/SRC/ctgexc.f
new file mode 100644
index 00000000..750c649b
--- /dev/null
+++ b/SRC/ctgexc.f
@@ -0,0 +1,206 @@
+      SUBROUTINE CTGEXC( 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            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGEXC 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 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 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 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 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           CTGEX2, XERBLA
+*     ..
+*     .. 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( 'CTGEXC', -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 CTGEX2( 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 CTGEX2( 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 CTGEXC
+*
+      END
diff --git a/SRC/ctgsen.f b/SRC/ctgsen.f
new file mode 100644
index 00000000..371df1d2
--- /dev/null
+++ b/SRC/ctgsen.f
@@ -0,0 +1,650 @@
+      SUBROUTINE CTGSEN( 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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
+     $                   M, N
+      REAL               PL, PR
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      REAL               DIF( * )
+      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGSEN 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.
+*
+*  CTGSEN 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 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 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 array, dimension (N)
+*  BETA    (output) COMPLEX 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 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 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) REAL
+*  PR	   (output) REAL
+*          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) REAL 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 CLACN2.
+*          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 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
+*  ===============
+*
+*  CTGSEN 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 CLATDF), then the parameter
+*  IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF
+*  (IJOB = 2 will be used)). See CTGSYL 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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP
+      INTEGER            I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2,
+     $                   N1, N2
+      REAL               DSCALE, DSUM, RDSCAL, SAFMIN
+      COMPLEX            TEMP1, TEMP2
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      REAL               SLAMCH 
+      EXTERNAL           CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC, CTGSYL,
+     $                   SLAMCH, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CMPLX, CONJG, MAX, 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 = -13
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -15
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTGSEN', -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( 'CTGSEN', -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 CLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
+               CALL CLASSQ( 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 = SLAMCH( '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 CTGEXC( 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 CLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
+         CALL CLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
+     $                N1 )
+         IJB = 0
+         CALL CTGSYL( '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 CLASSQ( 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 CLASSQ( 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 CTGSYL( '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 CTGSYL( '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 CLACN2. 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 CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE,
+     $                   ISAVE )
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve generalized Sylvester equation
+*
+                  CALL CTGSYL( '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 CTGSYL( '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 CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE,
+     $                   ISAVE )
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve generalized Sylvester equation
+*
+                  CALL CTGSYL( '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 CTGSYL( '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
+            TEMP1 = CONJG( B( K, K ) / DSCALE )
+            TEMP2 = B( K, K ) / DSCALE
+            B( K, K ) = DSCALE
+            CALL CSCAL( N-K, TEMP1, B( K, K+1 ), LDB )
+            CALL CSCAL( N-K+1, TEMP1, A( K, K ), LDA )
+            IF( WANTQ )
+     $         CALL CSCAL( N, TEMP2, Q( 1, K ), 1 )
+         ELSE
+            B( K, K ) = CMPLX( 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 CTGSEN
+*
+      END
diff --git a/SRC/ctgsja.f b/SRC/ctgsja.f
new file mode 100644
index 00000000..603b812c
--- /dev/null
+++ b/SRC/ctgsja.f
@@ -0,0 +1,525 @@
+      SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
+     $                   LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV,
+     $                   Q, LDQ, WORK, NCYCLE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
+     $                   NCYCLE, P
+      REAL               TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      REAL               ALPHA( * ), BETA( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGSJA computes the generalized singular value decomposition (GSVD)
+*  of two complex upper triangular (or trapezoidal) matrices A and B.
+*
+*  On entry, it is assumed that matrices A and B have the following
+*  forms, which may be obtained by the preprocessing subroutine CGGSVP
+*  from a general M-by-N matrix A and P-by-N matrix B:
+*
+*               N-K-L  K    L
+*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;
+*            L ( 0     0   A23 )
+*        M-K-L ( 0     0    0  )
+*
+*             N-K-L  K    L
+*     A =  K ( 0    A12  A13 ) if M-K-L < 0;
+*        M-K ( 0     0   A23 )
+*
+*             N-K-L  K    L
+*     B =  L ( 0     0   B13 )
+*        P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.
+*
+*  On exit,
+*
+*         U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),
+*
+*  where U, V and Q are unitary matrices, Z' denotes the conjugate
+*  transpose of Z, R is a nonsingular upper triangular matrix, and D1
+*  and D2 are ``diagonal'' matrices, which are of the following
+*  structures:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                     K  L
+*         D2 = L   ( 0  S )
+*              P-L ( 0  0 )
+*
+*                 N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 ) K
+*              L (  0    0   R22 ) L
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                 K M-K K+L-M
+*      D1 =   K ( I  0    0   )
+*           M-K ( 0  C    0   )
+*
+*                   K M-K K+L-M
+*      D2 =   M-K ( 0  S    0   )
+*           K+L-M ( 0  0    I   )
+*             P-L ( 0  0    0   )
+*
+*                 N-K-L  K   M-K  K+L-M
+* ( 0 R ) =    K ( 0    R11  R12  R13  )
+*            M-K ( 0     0   R22  R23  )
+*          K+L-M ( 0     0    0   R33  )
+*
+*  where
+*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*  S = diag( BETA(K+1),  ... , BETA(M) ),
+*  C**2 + S**2 = I.
+*
+*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
+*      (  0  R22 R23 )
+*  in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The computation of the unitary transformation matrices U, V or Q
+*  is optional.  These matrices may either be formed explicitly, or they
+*  may be postmultiplied into input matrices U1, V1, or Q1.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  U must contain a unitary matrix U1 on entry, and
+*                  the product U1*U is returned;
+*          = 'I':  U is initialized to the unit matrix, and the
+*                  unitary matrix U is returned;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  V must contain a unitary matrix V1 on entry, and
+*                  the product V1*V is returned;
+*          = 'I':  V is initialized to the unit matrix, and the
+*                  unitary matrix V is returned;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Q must contain a unitary matrix Q1 on entry, and
+*                  the product Q1*Q is returned;
+*          = 'I':  Q is initialized to the unit matrix, and the
+*                  unitary matrix Q is returned;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  K       (input) INTEGER
+*  L       (input) INTEGER
+*          K and L specify the subblocks in the input matrices A and B:
+*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)
+*          of A and B, whose GSVD is going to be computed by CTGSJA.
+*          See Further details.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
+*          matrix R or part of R.  See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
+*          a part of R.  See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) REAL
+*  TOLB    (input) REAL
+*          TOLA and TOLB are the convergence criteria for the Jacobi-
+*          Kogbetliantz iteration procedure. Generally, they are the
+*          same as used in the preprocessing step, say
+*              TOLA = MAX(M,N)*norm(A)*MACHEPS,
+*              TOLB = MAX(P,N)*norm(B)*MACHEPS.
+*
+*  ALPHA   (output) REAL array, dimension (N)
+*  BETA    (output) REAL array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = diag(C),
+*            BETA(K+1:K+L)  = diag(S),
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
+*          Furthermore, if K+L < N,
+*            ALPHA(K+L+1:N) = 0
+*            BETA(K+L+1:N)  = 0.
+*
+*  U       (input/output) COMPLEX array, dimension (LDU,M)
+*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
+*          the unitary matrix returned by CGGSVP).
+*          On exit,
+*          if JOBU = 'I', U contains the unitary matrix U;
+*          if JOBU = 'U', U contains the product U1*U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (input/output) COMPLEX array, dimension (LDV,P)
+*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
+*          the unitary matrix returned by CGGSVP).
+*          On exit,
+*          if JOBV = 'I', V contains the unitary matrix V;
+*          if JOBV = 'V', V contains the product V1*V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (input/output) COMPLEX array, dimension (LDQ,N)
+*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
+*          the unitary matrix returned by CGGSVP).
+*          On exit,
+*          if JOBQ = 'I', Q contains the unitary matrix Q;
+*          if JOBQ = 'Q', Q contains the product Q1*Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  NCYCLE  (output) INTEGER
+*          The number of cycles required for convergence.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the procedure does not converge after MAXIT cycles.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXIT   INTEGER
+*          MAXIT specifies the total loops that the iterative procedure
+*          may take. If after MAXIT cycles, the routine fails to
+*          converge, we return INFO = 1.
+*
+*  Further Details
+*  ===============
+*
+*  CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
+*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
+*  matrix B13 to the form:
+*
+*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
+*
+*  where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate
+*  transpose of Z.  C1 and S1 are diagonal matrices satisfying
+*
+*                C1**2 + S1**2 = I,
+*
+*  and R1 is an L-by-L nonsingular upper triangular matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 40 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+*
+      LOGICAL            INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
+      INTEGER            I, J, KCYCLE
+      REAL               A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
+     $                   RWK, SSMIN
+      COMPLEX            A2, B2, SNQ, SNU, SNV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CLAGS2, CLAPLL, CLASET, CROT, CSSCAL,
+     $                   SLARTG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CONJG, MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      INITU = LSAME( JOBU, 'I' )
+      WANTU = INITU .OR. LSAME( JOBU, 'U' )
+*
+      INITV = LSAME( JOBV, 'I' )
+      WANTV = INITV .OR. LSAME( JOBV, 'V' )
+*
+      INITQ = LSAME( JOBQ, 'I' )
+      WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -18
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -20
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -22
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTGSJA', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize U, V and Q, if necessary
+*
+      IF( INITU )
+     $   CALL CLASET( 'Full', M, M, CZERO, CONE, U, LDU )
+      IF( INITV )
+     $   CALL CLASET( 'Full', P, P, CZERO, CONE, V, LDV )
+      IF( INITQ )
+     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+*
+*     Loop until convergence
+*
+      UPPER = .FALSE.
+      DO 40 KCYCLE = 1, MAXIT
+*
+         UPPER = .NOT.UPPER
+*
+         DO 20 I = 1, L - 1
+            DO 10 J = I + 1, L
+*
+               A1 = ZERO
+               A2 = CZERO
+               A3 = ZERO
+               IF( K+I.LE.M )
+     $            A1 = REAL( A( K+I, N-L+I ) )
+               IF( K+J.LE.M )
+     $            A3 = REAL( A( K+J, N-L+J ) )
+*
+               B1 = REAL( B( I, N-L+I ) )
+               B3 = REAL( B( J, N-L+J ) )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A2 = A( K+I, N-L+J )
+                  B2 = B( I, N-L+J )
+               ELSE
+                  IF( K+J.LE.M )
+     $               A2 = A( K+J, N-L+I )
+                  B2 = B( J, N-L+I )
+               END IF
+*
+               CALL CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
+     $                      CSV, SNV, CSQ, SNQ )
+*
+*              Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
+*
+               IF( K+J.LE.M )
+     $            CALL CROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
+     $                       LDA, CSU, CONJG( SNU ) )
+*
+*              Update I-th and J-th rows of matrix B: V'*B
+*
+               CALL CROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
+     $                    CSV, CONJG( SNV ) )
+*
+*              Update (N-L+I)-th and (N-L+J)-th columns of matrices
+*              A and B: A*Q and B*Q
+*
+               CALL CROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
+     $                    A( 1, N-L+I ), 1, CSQ, SNQ )
+*
+               CALL CROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
+     $                    SNQ )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A( K+I, N-L+J ) = CZERO
+                  B( I, N-L+J ) = CZERO
+               ELSE
+                  IF( K+J.LE.M )
+     $               A( K+J, N-L+I ) = CZERO
+                  B( J, N-L+I ) = CZERO
+               END IF
+*
+*              Ensure that the diagonal elements of A and B are real.
+*
+               IF( K+I.LE.M )
+     $            A( K+I, N-L+I ) = REAL( A( K+I, N-L+I ) )
+               IF( K+J.LE.M )
+     $            A( K+J, N-L+J ) = REAL( A( K+J, N-L+J ) )
+               B( I, N-L+I ) = REAL( B( I, N-L+I ) )
+               B( J, N-L+J ) = REAL( B( J, N-L+J ) )
+*
+*              Update unitary matrices U, V, Q, if desired.
+*
+               IF( WANTU .AND. K+J.LE.M )
+     $            CALL CROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
+     $                       SNU )
+*
+               IF( WANTV )
+     $            CALL CROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
+*
+               IF( WANTQ )
+     $            CALL CROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
+     $                       SNQ )
+*
+   10       CONTINUE
+   20    CONTINUE
+*
+         IF( .NOT.UPPER ) THEN
+*
+*           The matrices A13 and B13 were lower triangular at the start
+*           of the cycle, and are now upper triangular.
+*
+*           Convergence test: test the parallelism of the corresponding
+*           rows of A and B.
+*
+            ERROR = ZERO
+            DO 30 I = 1, MIN( L, M-K )
+               CALL CCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
+               CALL CCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
+               CALL CLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
+               ERROR = MAX( ERROR, SSMIN )
+   30       CONTINUE
+*
+            IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
+     $         GO TO 50
+         END IF
+*
+*        End of cycle loop
+*
+   40 CONTINUE
+*
+*     The algorithm has not converged after MAXIT cycles.
+*
+      INFO = 1
+      GO TO 100
+*
+   50 CONTINUE
+*
+*     If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
+*     Compute the generalized singular value pairs (ALPHA, BETA), and
+*     set the triangular matrix R to array A.
+*
+      DO 60 I = 1, K
+         ALPHA( I ) = ONE
+         BETA( I ) = ZERO
+   60 CONTINUE
+*
+      DO 70 I = 1, MIN( L, M-K )
+*
+         A1 = REAL( A( K+I, N-L+I ) )
+         B1 = REAL( B( I, N-L+I ) )
+*
+         IF( A1.NE.ZERO ) THEN
+            GAMMA = B1 / A1
+*
+            IF( GAMMA.LT.ZERO ) THEN
+               CALL CSSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
+               IF( WANTV )
+     $            CALL CSSCAL( P, -ONE, V( 1, I ), 1 )
+            END IF
+*
+            CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
+     $                   RWK )
+*
+            IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
+               CALL CSSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
+     $                      LDA )
+            ELSE
+               CALL CSSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
+     $                      LDB )
+               CALL CCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                     LDA )
+            END IF
+*
+         ELSE
+            ALPHA( K+I ) = ZERO
+            BETA( K+I ) = ONE
+            CALL CCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                  LDA )
+         END IF
+   70 CONTINUE
+*
+*     Post-assignment
+*
+      DO 80 I = M + 1, K + L
+         ALPHA( I ) = ZERO
+         BETA( I ) = ONE
+   80 CONTINUE
+*
+      IF( K+L.LT.N ) THEN
+         DO 90 I = K + L + 1, N
+            ALPHA( I ) = ZERO
+            BETA( I ) = ZERO
+   90    CONTINUE
+      END IF
+*
+  100 CONTINUE
+      NCYCLE = KCYCLE
+*
+      RETURN
+*
+*     End of CTGSJA
+*
+      END
diff --git a/SRC/ctgsna.f b/SRC/ctgsna.f
new file mode 100644
index 00000000..71712573
--- /dev/null
+++ b/SRC/ctgsna.f
@@ -0,0 +1,397 @@
+      SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, JOB
+      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      REAL               DIF( * ), S( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or eigenvectors of a matrix pair (A, B).
+*
+*  (A, B) must be in generalized Schur canonical form, that is, A and
+*  B are both upper triangular.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (DIF):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (DIF);
+*          = 'B': for both eigenvalues and eigenvectors (S and DIF).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the corresponding j-th eigenvalue and/or eigenvector,
+*          SELECT(j) must be set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the square matrix pair (A, B). N >= 0.
+*
+*  A       (input) COMPLEX array, dimension (LDA,N)
+*          The upper triangular matrix A in the pair (A,B).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input) COMPLEX array, dimension (LDB,N)
+*          The upper triangular matrix B in the pair (A, B).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  VL      (input) COMPLEX array, dimension (LDVL,M)
+*          IF JOB = 'E' or 'B', VL must contain left eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT.  The eigenvectors must be stored in consecutive
+*          columns of VL, as returned by CTGEVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL. LDVL >= 1; and
+*          If JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) COMPLEX array, dimension (LDVR,M)
+*          IF JOB = 'E' or 'B', VR must contain right eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT.  The eigenvectors must be stored in consecutive
+*          columns of VR, as returned by CTGEVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR. LDVR >= 1;
+*          If JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) REAL array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array.
+*          If JOB = 'V', S is not referenced.
+*
+*  DIF     (output) REAL array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array.
+*          If the eigenvalues cannot be reordered to compute DIF(j),
+*          DIF(j) is set to 0; this can only occur when the true value
+*          would be very small anyway.
+*          For each eigenvalue/vector specified by SELECT, DIF stores
+*          a Frobenius norm-based estimate of Difl.
+*          If JOB = 'E', DIF is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S and DIF. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and DIF used to store
+*          the specified condition numbers; for each selected eigenvalue
+*          one element is used. If HOWMNY = 'A', M is set to N.
+*
+*  WORK    (workspace/output) COMPLEX 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 JOB = 'V' or 'B', LWORK >= max(1,2*N*N).
+*
+*  IWORK   (workspace) INTEGER array, dimension (N+2)
+*          If JOB = 'E', IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0: Successful exit
+*          < 0: If INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of the i-th generalized
+*  eigenvalue w = (a, b) is defined as
+*
+*          S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))
+*
+*  where u and v are the right and left eigenvectors of (A, B)
+*  corresponding to w; |z| denotes the absolute value of the complex
+*  number, and norm(u) denotes the 2-norm of the vector u. The pair
+*  (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the
+*  matrix pair (A, B). If both a and b equal zero, then (A,B) is
+*  singular and S(I) = -1 is returned.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*          chord(w, lambda) <=   EPS * norm(A, B) / S(I),
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number of the right eigenvector u
+*  and left eigenvector v corresponding to the generalized eigenvalue w
+*  is defined as follows. Suppose
+*
+*                   (A, B) = ( a   *  ) ( b  *  )  1
+*                            ( 0  A22 ),( 0 B22 )  n-1
+*                              1  n-1     1 n-1
+*
+*  Then the reciprocal condition number DIF(I) is
+*
+*          Difl[(a, b), (A22, B22)]  = sigma-min( Zl )
+*
+*  where sigma-min(Zl) denotes the smallest singular value of
+*
+*         Zl = [ kron(a, In-1) -kron(1, A22) ]
+*              [ kron(b, In-1) -kron(1, B22) ].
+*
+*  Here In-1 is the identity matrix of size n-1 and X' is the conjugate
+*  transpose of X. kron(X, Y) is the Kronecker product between the
+*  matrices X and Y.
+*
+*  We approximate the smallest singular value of Zl with an upper
+*  bound. This is done by CLATDF.
+*
+*  An approximate error bound for a computed eigenvector VL(i) or
+*  VR(i) is given by
+*
+*                      EPS * norm(A, B) / DIF(i).
+*
+*  See ref. [2-3] for more details and further references.
+*
+*  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 ..
+      REAL               ZERO, ONE
+      INTEGER            IDIFJB
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, IDIFJB = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SOMCON, WANTBH, WANTDF, WANTS
+      INTEGER            I, IERR, IFST, ILST, K, KS, LWMIN, N1, N2
+      REAL               BIGNUM, COND, EPS, LNRM, RNRM, SCALE, SMLNUM
+      COMPLEX            YHAX, YHBX
+*     ..
+*     .. Local Arrays ..
+      COMPLEX            DUMMY( 1 ), DUMMY1( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SCNRM2, SLAMCH, SLAPY2
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, SCNRM2, SLAMCH, SLAPY2, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMV, CLACPY, CTGEXC, CTGSYL, SLABAD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, CMPLX, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
+         INFO = -10
+      ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
+         INFO = -12
+      ELSE
+*
+*        Set M to the number of eigenpairs for which condition numbers
+*        are required, and test MM.
+*
+         IF( SOMCON ) THEN
+            M = 0
+            DO 10 K = 1, N
+               IF( SELECT( K ) )
+     $            M = M + 1
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( N.EQ.0 ) THEN
+            LWMIN = 1
+         ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
+            LWMIN = 2*N*N
+         ELSE
+            LWMIN = N
+         END IF
+         WORK( 1 ) = LWMIN
+*
+         IF( MM.LT.M ) THEN
+            INFO = -15
+         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTGSNA', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      KS = 0
+      DO 20 K = 1, N
+*
+*        Determine whether condition numbers are required for the k-th
+*        eigenpair.
+*
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( K ) )
+     $         GO TO 20
+         END IF
+*
+         KS = KS + 1
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            RNRM = SCNRM2( N, VR( 1, KS ), 1 )
+            LNRM = SCNRM2( N, VL( 1, KS ), 1 )
+            CALL CGEMV( 'N', N, N, CMPLX( ONE, ZERO ), A, LDA,
+     $                  VR( 1, KS ), 1, CMPLX( ZERO, ZERO ), WORK, 1 )
+            YHAX = CDOTC( N, WORK, 1, VL( 1, KS ), 1 )
+            CALL CGEMV( 'N', N, N, CMPLX( ONE, ZERO ), B, LDB,
+     $                  VR( 1, KS ), 1, CMPLX( ZERO, ZERO ), WORK, 1 )
+            YHBX = CDOTC( N, WORK, 1, VL( 1, KS ), 1 )
+            COND = SLAPY2( ABS( YHAX ), ABS( YHBX ) )
+            IF( COND.EQ.ZERO ) THEN
+               S( KS ) = -ONE
+            ELSE
+               S( KS ) = COND / ( RNRM*LNRM )
+            END IF
+         END IF
+*
+         IF( WANTDF ) THEN
+            IF( N.EQ.1 ) THEN
+               DIF( KS ) = SLAPY2( ABS( A( 1, 1 ) ), ABS( B( 1, 1 ) ) )
+            ELSE
+*
+*              Estimate the reciprocal condition number of the k-th
+*              eigenvectors.
+*
+*              Copy the matrix (A, B) to the array WORK and move the
+*              (k,k)th pair to the (1,1) position.
+*
+               CALL CLACPY( 'Full', N, N, A, LDA, WORK, N )
+               CALL CLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+               IFST = K
+               ILST = 1
+*
+               CALL CTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ),
+     $                      N, DUMMY, 1, DUMMY1, 1, IFST, ILST, IERR )
+*
+               IF( IERR.GT.0 ) THEN
+*
+*                 Ill-conditioned problem - swap rejected.
+*
+                  DIF( KS ) = ZERO
+               ELSE
+*
+*                 Reordering successful, solve generalized Sylvester
+*                 equation for R and L,
+*                            A22 * R - L * A11 = A12
+*                            B22 * R - L * B11 = B12,
+*                 and compute estimate of Difl[(A11,B11), (A22, B22)].
+*
+                  N1 = 1
+                  N2 = N - N1
+                  I = N*N + 1
+                  CALL CTGSYL( 'N', IDIFJB, N2, N1, WORK( N*N1+N1+1 ),
+     $                         N, WORK, N, WORK( N1+1 ), N,
+     $                         WORK( N*N1+N1+I ), N, WORK( I ), N,
+     $                         WORK( N1+I ), N, SCALE, DIF( KS ), DUMMY,
+     $                         1, IWORK, IERR )
+               END IF
+            END IF
+         END IF
+*
+   20 CONTINUE
+      WORK( 1 ) = LWMIN
+      RETURN
+*
+*     End of CTGSNA
+*
+      END
diff --git a/SRC/ctgsy2.f b/SRC/ctgsy2.f
new file mode 100644
index 00000000..2824e0cd
--- /dev/null
+++ b/SRC/ctgsy2.f
@@ -0,0 +1,361 @@
+      SUBROUTINE CTGSY2( 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
+      REAL               RDSCAL, RDSUM, SCALE
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGSY2 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 CLACON.
+*
+*  CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL
+*  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
+*  CTGSYL.
+*
+*  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. (SGECON 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 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 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 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 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 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 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) REAL
+*          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) REAL
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by CTGSYL, 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 CTGSY2 is called by
+*          CTGSYL.
+*
+*  RDSCAL  (input/output) REAL
+*          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 CTGSY2 is called by
+*          CTGSYL.
+*
+*  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 ..
+      REAL               ZERO, ONE
+      INTEGER            LDZ
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, LDZ = 2 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            I, IERR, J, K
+      REAL               SCALOC
+      COMPLEX            ALPHA
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IPIV( LDZ ), JPIV( LDZ )
+      COMPLEX            RHS( LDZ ), Z( LDZ, LDZ )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CGESC2, CGETC2, CSCAL, CLATDF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX, CONJG, 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( 'CTGSY2', -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 CGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
+               IF( IERR.GT.0 )
+     $            INFO = IERR
+               IF( IJOB.EQ.0 ) THEN
+                  CALL CGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 10 K = 1, N
+                        CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                              1 )
+                        CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                              1 )
+   10                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+               ELSE
+                  CALL CLATDF( 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 CAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ), 1 )
+                  CALL CAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ), 1 )
+               END IF
+               IF( J.LT.N ) THEN
+                  CALL CAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB,
+     $                        C( I, J+1 ), LDC )
+                  CALL CAXPY( 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 ) = CONJG( A( I, I ) )
+               Z( 2, 1 ) = -CONJG( B( J, J ) )
+               Z( 1, 2 ) = CONJG( D( I, I ) )
+               Z( 2, 2 ) = -CONJG( E( J, J ) )
+*
+*
+*              Set up right hand side(s)
+*
+               RHS( 1 ) = C( I, J )
+               RHS( 2 ) = F( I, J )
+*
+*              Solve Z' * x = RHS
+*
+               CALL CGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
+               IF( IERR.GT.0 )
+     $            INFO = IERR
+               CALL CGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 40 K = 1, N
+                     CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL CSCAL( M, CMPLX( 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 )*CONJG( B( K, J ) ) +
+     $                        RHS( 2 )*CONJG( E( K, J ) )
+   50          CONTINUE
+               DO 60 K = I + 1, M
+                  C( K, J ) = C( K, J ) - CONJG( A( I, K ) )*RHS( 1 ) -
+     $                        CONJG( D( I, K ) )*RHS( 2 )
+   60          CONTINUE
+*
+   70       CONTINUE
+   80    CONTINUE
+      END IF
+      RETURN
+*
+*     End of CTGSY2
+*
+      END
diff --git a/SRC/ctgsyl.f b/SRC/ctgsyl.f
new file mode 100644
index 00000000..d08d3d1f
--- /dev/null
+++ b/SRC/ctgsyl.f
@@ -0,0 +1,572 @@
+      SUBROUTINE CTGSYL( 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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
+     $                   LWORK, M, N
+      REAL               DIF, SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTGSYL 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 CLACON.
+*
+*  If IJOB >= 1, CTGSYL 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.
+*              (CGECON 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 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 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 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 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 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 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) REAL
+*          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) REAL
+*          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 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)
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CZERO
+      PARAMETER          ( CZERO = (0.0E+0, 0.0E+0) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOTRAN
+      INTEGER            I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
+     $                   LINFO, LWMIN, MB, NB, P, PQ, Q
+      REAL               DSCALE, DSUM, SCALE2, SCALOC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CGEMM, CLACPY, CLASET, CSCAL, CTGSY2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CMPLX, MAX, REAL, 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( 'CTGSYL', -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, 'CTGSYL', TRANS, M, N, -1, -1 )
+      NB = ILAENV( 5, 'CTGSYL', TRANS, M, N, -1, -1 )
+*
+      ISOLVE = 1
+      IFUNC = 0
+      IF( NOTRAN ) THEN
+         IF( IJOB.GE.3 ) THEN
+            IFUNC = IJOB - 2
+            CALL CLASET( 'F', M, N, CZERO, CZERO, C, LDC )
+            CALL CLASET( '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 CTGSY2( 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( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( REAL( 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 CLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL CLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL CLASET( 'F', M, N, CZERO, CZERO, C, LDC )
+               CALL CLASET( 'F', M, N, CZERO, CZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL CLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL CLACPY( '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 CTGSY2( 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 CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                              1 )
+                        CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                              1 )
+   80                CONTINUE
+                     DO 90 K = JS, JE
+                        CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ),
+     $                              C( 1, K ), 1 )
+                        CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ),
+     $                              F( 1, K ), 1 )
+   90                CONTINUE
+                     DO 100 K = JS, JE
+                        CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ),
+     $                              C( IE+1, K ), 1 )
+                        CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ),
+     $                              F( IE+1, K ), 1 )
+  100                CONTINUE
+                     DO 110 K = JE + 1, N
+                        CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                              1 )
+                        CALL CSCAL( M, CMPLX( 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 CGEMM( 'N', 'N', IS-1, NB, MB,
+     $                           CMPLX( -ONE, ZERO ), A( 1, IS ), LDA,
+     $                           C( IS, JS ), LDC, CMPLX( ONE, ZERO ),
+     $                           C( 1, JS ), LDC )
+                     CALL CGEMM( 'N', 'N', IS-1, NB, MB,
+     $                           CMPLX( -ONE, ZERO ), D( 1, IS ), LDD,
+     $                           C( IS, JS ), LDC, CMPLX( ONE, ZERO ),
+     $                           F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL CGEMM( 'N', 'N', MB, N-JE, NB,
+     $                           CMPLX( ONE, ZERO ), F( IS, JS ), LDF,
+     $                           B( JS, JE+1 ), LDB, CMPLX( ONE, ZERO ),
+     $                           C( IS, JE+1 ), LDC )
+                     CALL CGEMM( 'N', 'N', MB, N-JE, NB,
+     $                           CMPLX( ONE, ZERO ), F( IS, JS ), LDF,
+     $                           E( JS, JE+1 ), LDE, CMPLX( 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( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( REAL( 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 CLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL CLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL CLASET( 'F', M, N, CZERO, CZERO, C, LDC )
+               CALL CLASET( 'F', M, N, CZERO, CZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL CLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL CLACPY( '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 CTGSY2( 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 CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL CSCAL( M, CMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                           1 )
+  160             CONTINUE
+                  DO 170 K = JS, JE
+                     CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL CSCAL( IS-1, CMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                           1 )
+  170             CONTINUE
+                  DO 180 K = JS, JE
+                     CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ),
+     $                           C( IE+1, K ), 1 )
+                     CALL CSCAL( M-IE, CMPLX( SCALOC, ZERO ),
+     $                           F( IE+1, K ), 1 )
+  180             CONTINUE
+                  DO 190 K = JE + 1, N
+                     CALL CSCAL( M, CMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL CSCAL( M, CMPLX( 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 CGEMM( 'N', 'C', MB, JS-1, NB,
+     $                        CMPLX( ONE, ZERO ), C( IS, JS ), LDC,
+     $                        B( 1, JS ), LDB, CMPLX( ONE, ZERO ),
+     $                        F( IS, 1 ), LDF )
+                  CALL CGEMM( 'N', 'C', MB, JS-1, NB,
+     $                        CMPLX( ONE, ZERO ), F( IS, JS ), LDF,
+     $                        E( 1, JS ), LDE, CMPLX( ONE, ZERO ),
+     $                        F( IS, 1 ), LDF )
+               END IF
+               IF( I.LT.P ) THEN
+                  CALL CGEMM( 'C', 'N', M-IE, NB, MB,
+     $                        CMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA,
+     $                        C( IS, JS ), LDC, CMPLX( ONE, ZERO ),
+     $                        C( IE+1, JS ), LDC )
+                  CALL CGEMM( 'C', 'N', M-IE, NB, MB,
+     $                        CMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD,
+     $                        F( IS, JS ), LDF, CMPLX( ONE, ZERO ),
+     $                        C( IE+1, JS ), LDC )
+               END IF
+  200       CONTINUE
+  210    CONTINUE
+      END IF
+*
+      WORK( 1 ) = LWMIN
+*
+      RETURN
+*
+*     End of CTGSYL
+*
+      END
diff --git a/SRC/ctpcon.f b/SRC/ctpcon.f
new file mode 100644
index 00000000..1954ef24
--- /dev/null
+++ b/SRC/ctpcon.f
@@ -0,0 +1,198 @@
+      SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, N
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTPCON estimates the reciprocal of the condition number of a packed
+*  triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  RCOND   (output) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               CLANTP, SLAMCH
+      EXTERNAL           LSAME, ICAMAX, CLANTP, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATPS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = CLANTP( NORM, UPLO, DIAG, N, AP, RWORK )
+*
+*     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 CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL CLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
+     $                      WORK, SCALE, RWORK, INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL CLATPS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
+     $                      N, AP, WORK, SCALE, RWORK, INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = ICAMAX( N, WORK, 1 )
+               XNORM = CABS1( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL CSRSCL( 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 CTPCON
+*
+      END
diff --git a/SRC/ctprfs.f b/SRC/ctprfs.f
new file mode 100644
index 00000000..d9cb2283
--- /dev/null
+++ b/SRC/ctprfs.f
@@ -0,0 +1,391 @@
+      SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
+     $                   FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTPRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular packed
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by CTPTRS or some other
+*  means before entering this routine.  CTPRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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)
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  B       (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          The solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANSN, TRANST
+      INTEGER            I, J, K, KASE, KC, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CLACN2, CTPMV, CTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL CCOPY( N, X( 1, J ), 1, WORK, 1 )
+         CALL CTPMV( UPLO, TRANS, DIAG, N, AP, WORK, 1 )
+         CALL CAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 30 I = 1, K
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-1 ) )*XK
+   30                CONTINUE
+                     KC = KC + K
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-1 ) )*XK
+   50                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+                     KC = KC + K
+   60             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 70 I = K, N
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-K ) )*XK
+   70                CONTINUE
+                     KC = KC + N - K + 1
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-K ) )*XK
+   90                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+                     KC = KC + N - K + 1
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A**H)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + CABS1( AP( KC+I-1 ) )*CABS1( X( I, J ) )
+  110                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + K
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + CABS1( AP( KC+I-1 ) )*CABS1( X( I, J ) )
+  130                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + K
+  140             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + CABS1( AP( KC+I-K ) )*CABS1( X( I, J ) )
+  150                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + N - K + 1
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + CABS1( AP( KC+I-K ) )*CABS1( X( I, J ) )
+  170                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + N - K + 1
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL CTPSV( UPLO, TRANST, DIAG, N, AP, WORK, 1 )
+               DO 220 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  230          CONTINUE
+               CALL CTPSV( UPLO, TRANSN, DIAG, N, AP, WORK, 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of CTPRFS
+*
+      END
diff --git a/SRC/ctptri.f b/SRC/ctptri.f
new file mode 100644
index 00000000..3d63400c
--- /dev/null
+++ b/SRC/ctptri.f
@@ -0,0 +1,176 @@
+      SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTPTRI computes the inverse of a complex upper or lower triangular
+*  matrix A stored in packed format.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangular matrix A, stored
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same packed storage format.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  A triangular matrix A can be transferred to packed storage using one
+*  of the following program segments:
+*
+*  UPLO = 'U':                      UPLO = 'L':
+*
+*        JC = 1                           JC = 1
+*        DO 2 J = 1, N                    DO 2 J = 1, N
+*           DO 1 I = 1, J                    DO 1 I = J, N
+*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
+*      1    CONTINUE                    1    CONTINUE
+*           JC = JC + J                      JC = JC + N - J + 1
+*      2 CONTINUE                       2 CONTINUE
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC, JCLAST, JJ
+      COMPLEX            AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSCAL, CTPMV, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Check for singularity if non-unit.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JJ = 0
+            DO 10 INFO = 1, N
+               JJ = JJ + INFO
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            JJ = 1
+            DO 20 INFO = 1, N
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+               JJ = JJ + N - INFO + 1
+   20       CONTINUE
+         END IF
+         INFO = 0
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Compute inverse of upper triangular matrix.
+*
+         JC = 1
+         DO 30 J = 1, N
+            IF( NOUNIT ) THEN
+               AP( JC+J-1 ) = ONE / AP( JC+J-1 )
+               AJJ = -AP( JC+J-1 )
+            ELSE
+               AJJ = -ONE
+            END IF
+*
+*           Compute elements 1:j-1 of j-th column.
+*
+            CALL CTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
+     $                  AP( JC ), 1 )
+            CALL CSCAL( J-1, AJJ, AP( JC ), 1 )
+            JC = JC + J
+   30    CONTINUE
+*
+      ELSE
+*
+*        Compute inverse of lower triangular matrix.
+*
+         JC = N*( N+1 ) / 2
+         DO 40 J = N, 1, -1
+            IF( NOUNIT ) THEN
+               AP( JC ) = ONE / AP( JC )
+               AJJ = -AP( JC )
+            ELSE
+               AJJ = -ONE
+            END IF
+            IF( J.LT.N ) THEN
+*
+*              Compute elements j+1:n of j-th column.
+*
+               CALL CTPMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     AP( JCLAST ), AP( JC+1 ), 1 )
+               CALL CSCAL( N-J, AJJ, AP( JC+1 ), 1 )
+            END IF
+            JCLAST = JC
+            JC = JC - N + J - 2
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CTPTRI
+*
+      END
diff --git a/SRC/ctptrs.f b/SRC/ctptrs.f
new file mode 100644
index 00000000..2471498e
--- /dev/null
+++ b/SRC/ctptrs.f
@@ -0,0 +1,153 @@
+      SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTPTRS solves a triangular system of the form
+*
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*
+*  where A is a triangular matrix of order N stored in packed format,
+*  and B is an N-by-NRHS matrix.  A check is made to verify that A is
+*  nonsingular.
+*
+*  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)
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  B       (input/output) COMPLEX 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 ..
+      COMPLEX            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTPTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JC = 1
+            DO 10 INFO = 1, N
+               IF( AP( JC+INFO-1 ).EQ.ZERO )
+     $            RETURN
+               JC = JC + INFO
+   10       CONTINUE
+         ELSE
+            JC = 1
+            DO 20 INFO = 1, N
+               IF( AP( JC ).EQ.ZERO )
+     $            RETURN
+               JC = JC + N - INFO + 1
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve  A * x = b,  A**T * x = b,  or  A**H * x = b.
+*
+      DO 30 J = 1, NRHS
+         CALL CTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of CTPTRS
+*
+      END
diff --git a/SRC/ctrcon.f b/SRC/ctrcon.f
new file mode 100644
index 00000000..388db1c3
--- /dev/null
+++ b/SRC/ctrcon.f
@@ -0,0 +1,204 @@
+      SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
+     $                   RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, LDA, N
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               RWORK( * )
+      COMPLEX            A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRCON 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) COMPLEX 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) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               CLANTR, SLAMCH
+      EXTERNAL           LSAME, ICAMAX, CLANTR, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLATRS, CSRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'CTRCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = CLANTR( NORM, UPLO, DIAG, N, N, A, LDA, RWORK )
+*
+*     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 CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL CLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
+     $                      LDA, WORK, SCALE, RWORK, INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL CLATRS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
+     $                      N, A, LDA, WORK, SCALE, RWORK, INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = ICAMAX( N, WORK, 1 )
+               XNORM = CABS1( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL CSRSCL( 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 CTRCON
+*
+      END
diff --git a/SRC/ctrevc.f b/SRC/ctrevc.f
new file mode 100644
index 00000000..bfc8011a
--- /dev/null
+++ b/SRC/ctrevc.f
@@ -0,0 +1,386 @@
+      SUBROUTINE CTREVC( 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( * )
+      REAL               RWORK( * )
+      COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTREVC 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 CHSEQR.
+*  
+*  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 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 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 CHSEQR).
+*          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 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 CHSEQR).
+*          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 array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      COMPLEX            CMZERO, CMONE
+      PARAMETER          ( CMZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CMONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
+      INTEGER            I, II, IS, J, K, KI
+      REAL               OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
+      COMPLEX            CDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SCASUM, SLAMCH
+      EXTERNAL           LSAME, ICAMAX, SCASUM, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CCOPY, CGEMV, CLATRS, CSSCAL, SLABAD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( 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( 'CTREVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set the constants to control overflow.
+*
+      UNFL = SLAMCH( 'Safe minimum' )
+      OVFL = ONE / UNFL
+      CALL SLABAD( UNFL, OVFL )
+      ULP = SLAMCH( '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 ) = SCASUM( 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 CLATRS( '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 CCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 )
+*
+               II = ICAMAX( KI, VR( 1, IS ), 1 )
+               REMAX = ONE / CABS1( VR( II, IS ) )
+               CALL CSSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+               DO 60 K = KI + 1, N
+                  VR( K, IS ) = CMZERO
+   60          CONTINUE
+            ELSE
+               IF( KI.GT.1 )
+     $            CALL CGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ),
+     $                        1, CMPLX( SCALE ), VR( 1, KI ), 1 )
+*
+               II = ICAMAX( N, VR( 1, KI ), 1 )
+               REMAX = ONE / CABS1( VR( II, KI ) )
+               CALL CSSCAL( 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 ) = -CONJG( 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 CLATRS( '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 CCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 )
+*
+               II = ICAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
+               REMAX = ONE / CABS1( VL( II, IS ) )
+               CALL CSSCAL( 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 CGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL,
+     $                        WORK( KI+1 ), 1, CMPLX( SCALE ),
+     $                        VL( 1, KI ), 1 )
+*
+               II = ICAMAX( N, VL( 1, KI ), 1 )
+               REMAX = ONE / CABS1( VL( II, KI ) )
+               CALL CSSCAL( 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 CTREVC
+*
+      END
diff --git a/SRC/ctrexc.f b/SRC/ctrexc.f
new file mode 100644
index 00000000..c6a450d3
--- /dev/null
+++ b/SRC/ctrexc.f
@@ -0,0 +1,161 @@
+      SUBROUTINE CTREXC( 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            Q( LDQ, * ), T( LDT, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTREXC 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 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 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
+      REAL               CS
+      COMPLEX            SN, T11, T22, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARTG, CROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CTREXC', -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 CLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP )
+*
+*        Apply transformation to the matrix T.
+*
+         IF( K+2.LE.N )
+     $      CALL CROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS,
+     $                 SN )
+         CALL CROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, CONJG( SN ) )
+*
+         T( K, K ) = T22
+         T( K+1, K+1 ) = T11
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL CROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS,
+     $                 CONJG( SN ) )
+         END IF
+*
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of CTREXC
+*
+      END
diff --git a/SRC/ctrrfs.f b/SRC/ctrrfs.f
new file mode 100644
index 00000000..8f7bb960
--- /dev/null
+++ b/SRC/ctrrfs.f
@@ -0,0 +1,382 @@
+      SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
+     $                   LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDA, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX            A( LDA, * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by CTRTRS or some other
+*  means before entering this routine.  CTRRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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)
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)
+*          The solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) COMPLEX array, dimension (2*N)
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      COMPLEX            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANSN, TRANST
+      INTEGER            I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX            ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CLACN2, CTRMV, CTRSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTRRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL CCOPY( N, X( 1, J ), 1, WORK, 1 )
+         CALL CTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK, 1 )
+         CALL CAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 30 I = 1, K
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   50                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 70 I = K, N
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   90                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A**H)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  110                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  130                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  150                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  170                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use CLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL CLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL CTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK, 1 )
+               DO 220 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  230          CONTINUE
+               CALL CTRSV( UPLO, TRANSN, DIAG, N, A, LDA, WORK, 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of CTRRFS
+*
+      END
diff --git a/SRC/ctrsen.f b/SRC/ctrsen.f
new file mode 100644
index 00000000..085a6518
--- /dev/null
+++ b/SRC/ctrsen.f
@@ -0,0 +1,359 @@
+      SUBROUTINE CTRSEN( 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 CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, JOB
+      INTEGER            INFO, LDQ, LDT, LWORK, M, N
+      REAL               S, SEP
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      COMPLEX            Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRSEN 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 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 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 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) REAL
+*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+*          condition number for the selected cluster of eigenvalues.
+*          S cannot underestimate the true reciprocal condition number
+*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+*          If JOB = 'N' or 'V', S is not referenced.
+*
+*  SEP     (output) REAL
+*          If JOB = 'V' or 'B', SEP is the estimated reciprocal
+*          condition number of the specified invariant subspace. If
+*          M = 0 or N, SEP = norm(T).
+*          If JOB = 'N' or 'E', SEP is not referenced.
+*
+*  WORK    (workspace/output) COMPLEX 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
+*  ===============
+*
+*  CTRSEN 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTBH, WANTQ, WANTS, WANTSP
+      INTEGER            IERR, K, KASE, KS, LWMIN, N1, N2, NN
+      REAL               EST, RNORM, SCALE
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+      REAL               RWORK( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANGE
+      EXTERNAL           LSAME, CLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLACPY, CTREXC, CTRSYL, XERBLA
+*     ..
+*     .. 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( 'CTRSEN', -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 = CLANGE( '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 CTREXC( 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 CLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
+         CALL CTRSYL( '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 = CLANGE( '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 CLACN2( 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 CTRSYL( '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 CTRSYL( '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 CTRSEN
+*
+      END
diff --git a/SRC/ctrsna.f b/SRC/ctrsna.f
new file mode 100644
index 00000000..d098804d
--- /dev/null
+++ b/SRC/ctrsna.f
@@ -0,0 +1,356 @@
+      SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, JOB
+      INTEGER            INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      REAL               RWORK( * ), S( * ), SEP( * )
+      COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or right eigenvectors of a complex upper triangular
+*  matrix T (or of any matrix Q*T*Q**H with Q unitary).
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (SEP):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (SEP);
+*          = 'B': for both eigenvalues and eigenvectors (S and SEP).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the j-th eigenpair, SELECT(j) must be set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input) COMPLEX array, dimension (LDT,N)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  VL      (input) COMPLEX array, dimension (LDVL,M)
+*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
+*          (or of any Q*T*Q**H with Q unitary), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VL, as returned by
+*          CHSEIN or CTREVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) COMPLEX array, dimension (LDVR,M)
+*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
+*          (or of any Q*T*Q**H with Q unitary), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VR, as returned by
+*          CHSEIN or CTREVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) REAL array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array. Thus S(j), SEP(j), and the j-th columns of VL and VR
+*          all correspond to the same eigenpair (but not in general the
+*          j-th eigenpair, unless all eigenpairs are selected).
+*          If JOB = 'V', S is not referenced.
+*
+*  SEP     (output) REAL array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array.
+*          If JOB = 'E', SEP is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S (if JOB = 'E' or 'B')
+*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and/or SEP actually
+*          used to store the estimated condition numbers.
+*          If HOWMNY = 'A', M is set to N.
+*
+*  WORK    (workspace) COMPLEX array, dimension (LDWORK,N+6)
+*          If JOB = 'E', WORK is not referenced.
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
+*
+*  RWORK   (workspace) REAL array, dimension (N)
+*          If JOB = 'E', RWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of an eigenvalue lambda is
+*  defined as
+*
+*          S(lambda) = |v'*u| / (norm(u)*norm(v))
+*
+*  where u and v are the right and left eigenvectors of T corresponding
+*  to lambda; v' denotes the conjugate transpose of v, and norm(u)
+*  denotes the Euclidean norm. These reciprocal condition numbers always
+*  lie between zero (very badly conditioned) and one (very well
+*  conditioned). If n = 1, S(lambda) is defined to be 1.
+*
+*  An approximate error bound for a computed eigenvalue W(i) is given by
+*
+*                      EPS * norm(T) / S(i)
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number of the right eigenvector u
+*  corresponding to lambda is defined as follows. Suppose
+*
+*              T = ( lambda  c  )
+*                  (   0    T22 )
+*
+*  Then the reciprocal condition number is
+*
+*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
+*
+*  where sigma-min denotes the smallest singular value. We approximate
+*  the smallest singular value by the reciprocal of an estimate of the
+*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
+*  defined to be abs(T(1,1)).
+*
+*  An approximate error bound for a computed right eigenvector VR(i)
+*  is given by
+*
+*                      EPS * norm(T) / SEP(i)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SOMCON, WANTBH, WANTS, WANTSP
+      CHARACTER          NORMIN
+      INTEGER            I, IERR, IX, J, K, KASE, KS
+      REAL               BIGNUM, EPS, EST, LNRM, RNRM, SCALE, SMLNUM,
+     $                   XNORM
+      COMPLEX            CDUM, PROD
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+      COMPLEX            DUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ICAMAX
+      REAL               SCNRM2, SLAMCH
+      COMPLEX            CDOTC
+      EXTERNAL           LSAME, ICAMAX, SCNRM2, SLAMCH, CDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACN2, CLACPY, CLATRS, CSRSCL, CTREXC, SLABAD,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, MAX, REAL
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+*     Set M to the number of eigenpairs for which condition numbers are
+*     to be computed.
+*
+      IF( SOMCON ) 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.WANTS .AND. .NOT.WANTSP ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -13
+      ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CTRSNA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( 1 ) )
+     $         RETURN
+         END IF
+         IF( WANTS )
+     $      S( 1 ) = ONE
+         IF( WANTSP )
+     $      SEP( 1 ) = ABS( T( 1, 1 ) )
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+      KS = 1
+      DO 50 K = 1, N
+*
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( K ) )
+     $         GO TO 50
+         END IF
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            PROD = CDOTC( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+            RNRM = SCNRM2( N, VR( 1, KS ), 1 )
+            LNRM = SCNRM2( N, VL( 1, KS ), 1 )
+            S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
+*
+         END IF
+*
+         IF( WANTSP ) THEN
+*
+*           Estimate the reciprocal condition number of the k-th
+*           eigenvector.
+*
+*           Copy the matrix T to the array WORK and swap the k-th
+*           diagonal element to the (1,1) position.
+*
+            CALL CLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
+            CALL CTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, K, 1, IERR )
+*
+*           Form  C = T22 - lambda*I in WORK(2:N,2:N).
+*
+            DO 20 I = 2, N
+               WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
+   20       CONTINUE
+*
+*           Estimate a lower bound for the 1-norm of inv(C'). The 1st
+*           and (N+1)th columns of WORK are used to store work vectors.
+*
+            SEP( KS ) = ZERO
+            EST = ZERO
+            KASE = 0
+            NORMIN = 'N'
+   30       CONTINUE
+            CALL CLACN2( N-1, WORK( 1, N+1 ), WORK, EST, KASE, ISAVE )
+*
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve C'*x = scale*b
+*
+                  CALL CLATRS( 'Upper', 'Conjugate transpose',
+     $                         'Nonunit', NORMIN, N-1, WORK( 2, 2 ),
+     $                         LDWORK, WORK, SCALE, RWORK, IERR )
+               ELSE
+*
+*                 Solve C*x = scale*b
+*
+                  CALL CLATRS( 'Upper', 'No transpose', 'Nonunit',
+     $                         NORMIN, N-1, WORK( 2, 2 ), LDWORK, WORK,
+     $                         SCALE, RWORK, IERR )
+               END IF
+               NORMIN = 'Y'
+               IF( SCALE.NE.ONE ) THEN
+*
+*                 Multiply by 1/SCALE if doing so will not cause
+*                 overflow.
+*
+                  IX = ICAMAX( N-1, WORK, 1 )
+                  XNORM = CABS1( WORK( IX, 1 ) )
+                  IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $               GO TO 40
+                  CALL CSRSCL( N, SCALE, WORK, 1 )
+               END IF
+               GO TO 30
+            END IF
+*
+            SEP( KS ) = ONE / MAX( EST, SMLNUM )
+         END IF
+*
+   40    CONTINUE
+         KS = KS + 1
+   50 CONTINUE
+      RETURN
+*
+*     End of CTRSNA
+*
+      END
diff --git a/SRC/ctrsyl.f b/SRC/ctrsyl.f
new file mode 100644
index 00000000..6f0137ed
--- /dev/null
+++ b/SRC/ctrsyl.f
@@ -0,0 +1,365 @@
+      SUBROUTINE CTRSYL( 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
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRSYL 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 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 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 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) REAL
+*          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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRNA, NOTRNB
+      INTEGER            J, K, L
+      REAL               BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
+     $                   SMLNUM
+      COMPLEX            A11, SUML, SUMR, VEC, X11
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               CLANGE, SLAMCH
+      COMPLEX            CDOTC, CDOTU, CLADIV
+      EXTERNAL           LSAME, CLANGE, SLAMCH, CDOTC, CDOTU, CLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSSCAL, SLABAD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL
+*     ..
+*     .. 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( 'CTRSYL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM*REAL( M*N ) / EPS
+      BIGNUM = ONE / SMLNUM
+      SMIN = MAX( SMLNUM, EPS*CLANGE( 'M', M, M, A, LDA, DUM ),
+     $       EPS*CLANGE( '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 = CDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
+     $                C( MIN( K+1, M ), L ), 1 )
+               SUMR = CDOTU( 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( REAL( A11 ) ) + ABS( AIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+               X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 10 J = 1, N
+                     CALL CSSCAL( 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 = CDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
+               SUMR = CDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
+               VEC = C( K, L ) - ( SUML+SGN*SUMR )
+*
+               SCALOC = ONE
+               A11 = CONJG( A( K, K ) ) + SGN*B( L, L )
+               DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+*
+               X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 40 J = 1, N
+                     CALL CSSCAL( 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 = CDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
+               SUMR = CDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
+     $                B( L, MIN( L+1, N ) ), LDB )
+               VEC = C( K, L ) - ( SUML+SGN*CONJG( SUMR ) )
+*
+               SCALOC = ONE
+               A11 = CONJG( A( K, K )+SGN*B( L, L ) )
+               DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+*
+               X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 70 J = 1, N
+                     CALL CSSCAL( 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 = CDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
+     $                C( MIN( K+1, M ), L ), 1 )
+               SUMR = CDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
+     $                B( L, MIN( L+1, N ) ), LDB )
+               VEC = C( K, L ) - ( SUML+SGN*CONJG( SUMR ) )
+*
+               SCALOC = ONE
+               A11 = A( K, K ) + SGN*CONJG( B( L, L ) )
+               DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+*
+               X11 = CLADIV( VEC*CMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 100 J = 1, N
+                     CALL CSSCAL( 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 CTRSYL
+*
+      END
diff --git a/SRC/ctrti2.f b/SRC/ctrti2.f
new file mode 100644
index 00000000..f9aa3241
--- /dev/null
+++ b/SRC/ctrti2.f
@@ -0,0 +1,146 @@
+      SUBROUTINE CTRTI2( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRTI2 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+      COMPLEX            AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CSCAL, CTRMV, 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( 'CTRTI2', -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 CTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
+     $                  A( 1, J ), 1 )
+            CALL CSCAL( 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 CTRMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
+               CALL CSCAL( N-J, AJJ, A( J+1, J ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CTRTI2
+*
+      END
diff --git a/SRC/ctrtri.f b/SRC/ctrtri.f
new file mode 100644
index 00000000..ffd2f6fa
--- /dev/null
+++ b/SRC/ctrtri.f
@@ -0,0 +1,177 @@
+      SUBROUTINE CTRTRI( 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            A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRTRI 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 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            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JB, NB, NN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTRMM, CTRSM, CTRTI2, 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( 'CTRTRI', -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, 'CTRTRI', UPLO // DIAG, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL CTRTI2( 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 CTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
+               CALL CTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
+*
+*              Compute inverse of current diagonal block
+*
+               CALL CTRTI2( '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 CTRMM( 'Left', 'Lower', 'No transpose', DIAG,
+     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
+     $                        A( J+JB, J ), LDA )
+                  CALL CTRSM( '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 CTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
+   30       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of CTRTRI
+*
+      END
diff --git a/SRC/ctrtrs.f b/SRC/ctrtrs.f
new file mode 100644
index 00000000..fbb45d54
--- /dev/null
+++ b/SRC/ctrtrs.f
@@ -0,0 +1,148 @@
+      SUBROUTINE CTRTRS( 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 ..
+      COMPLEX            A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTRTRS solves a triangular system of the form
+*
+*     A * X = B,  A**T * X = B,  or  A**H * 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)
+*
+*  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) COMPLEX 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) COMPLEX 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 ..
+      COMPLEX            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CTRSM, 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( 'CTRTRS', -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,  A**T * x = b,  or  A**H * x = b.
+*
+      CALL CTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+     $            LDB )
+*
+      RETURN
+*
+*     End of CTRTRS
+*
+      END
diff --git a/SRC/ctzrqf.f b/SRC/ctzrqf.f
new file mode 100644
index 00000000..923256a2
--- /dev/null
+++ b/SRC/ctzrqf.f
@@ -0,0 +1,173 @@
+      SUBROUTINE CTZRQF( 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 ..
+      COMPLEX            A( LDA, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine CTZRZF.
+*
+*  CTZRQF 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 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 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 ), whose conjugate transpose 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            CONE, CZERO
+      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
+     $                   CZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K, M1
+      COMPLEX            ALPHA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CAXPY, CCOPY, CGEMV, CGERC, CLACGV, CLARFG,
+     $                   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( 'CTZRQF', -INFO )
+         RETURN
+      END IF
+*
+*     Perform the factorization.
+*
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = CZERO
+   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.
+*
+            A( K, K ) = CONJG( A( K, K ) )
+            CALL CLACGV( N-M, A( K, M1 ), LDA )
+            ALPHA = A( K, K )
+            CALL CLARFG( N-M+1, ALPHA, A( K, M1 ), LDA, TAU( K ) )
+            A( K, K ) = ALPHA
+            TAU( K ) = CONJG( TAU( K ) )
+*
+            IF( TAU( K ).NE.CZERO .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 CCOPY( K-1, A( 1, K ), 1, TAU, 1 )
+*
+*              Form   w = a( k ) + B*z( k )  in TAU.
+*
+               CALL CGEMV( 'No transpose', K-1, N-M, CONE, A( 1, M1 ),
+     $                     LDA, A( K, M1 ), LDA, CONE, TAU, 1 )
+*
+*              Now form  a( k ) := a( k ) - conjg(tau)*w
+*              and       B      := B      - conjg(tau)*w*z( k )'.
+*
+               CALL CAXPY( K-1, -CONJG( TAU( K ) ), TAU, 1, A( 1, K ),
+     $                     1 )
+               CALL CGERC( K-1, N-M, -CONJG( TAU( K ) ), TAU, 1,
+     $                     A( K, M1 ), LDA, A( 1, M1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of CTZRQF
+*
+      END
diff --git a/SRC/ctzrzf.f b/SRC/ctzrzf.f
new file mode 100644
index 00000000..156b9941
--- /dev/null
+++ b/SRC/ctzrzf.f
@@ -0,0 +1,246 @@
+      SUBROUTINE CTZRZF( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CTZRZF 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 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 array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARZB, CLARZT, CLATRZ, 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
+      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      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, 'CGERQF', ' ', 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( 'CTZRZF', -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, 'CGERQF', ' ', 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, 'CGERQF', ' ', 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 CLATRZ( 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 CLARZT( '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 CLARZB( '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 CLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of CTZRZF
+*
+      END
diff --git a/SRC/cung2l.f b/SRC/cung2l.f
new file mode 100644
index 00000000..1a253d63
--- /dev/null
+++ b/SRC/cung2l.f
@@ -0,0 +1,128 @@
+      SUBROUTINE CUNG2L( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNG2L 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 CGEQLF.
+*
+*  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 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 CGEQLF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQLF.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CSCAL, 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( 'CUNG2L', -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 CLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+     $               LDA, WORK )
+         CALL CSCAL( 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 CUNG2L
+*
+      END
diff --git a/SRC/cung2r.f b/SRC/cung2r.f
new file mode 100644
index 00000000..9edfe64f
--- /dev/null
+++ b/SRC/cung2r.f
@@ -0,0 +1,130 @@
+      SUBROUTINE CUNG2R( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNG2R 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 CGEQRF.
+*
+*  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 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 CGEQRF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQRF.
+*
+*  WORK    (workspace) COMPLEX array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, CSCAL, 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( 'CUNG2R', -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 CLARF( '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 CSCAL( 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 CUNG2R
+*
+      END
diff --git a/SRC/cungbr.f b/SRC/cungbr.f
new file mode 100644
index 00000000..8814e850
--- /dev/null
+++ b/SRC/cungbr.f
@@ -0,0 +1,245 @@
+      SUBROUTINE CUNGBR( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGBR generates one of the complex unitary matrices Q or P**H
+*  determined by CGEBRD 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 CUNGBR returns the first n
+*  columns of Q, where m >= n >= k;
+*  if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR 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 CUNGBR 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 CUNGBR 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 CGEBRD:
+*          = '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 CGEBRD.
+*          If VECT = 'P', the number of rows in the original K-by-N
+*          matrix reduced by CGEBRD.
+*          K >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by CGEBRD.
+*          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 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 CGEBRD in its array argument TAUQ or TAUP.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTQ
+      INTEGER            I, IINFO, J, LWKOPT, MN, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNGLQ, CUNGQR, 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, 'CUNGQR', ' ', M, N, K, -1 )
+         ELSE
+            NB = ILAENV( 1, 'CUNGLQ', ' ', M, N, K, -1 )
+         END IF
+         LWKOPT = MAX( 1, MN )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CUNGBR', -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 CGEBRD to reduce an m-by-k
+*        matrix
+*
+         IF( M.GE.K ) THEN
+*
+*           If m >= k, assume m >= n >= k
+*
+            CALL CUNGQR( 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 CUNGQR( 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 CGEBRD to reduce a k-by-n
+*        matrix
+*
+         IF( K.LT.N ) THEN
+*
+*           If k < n, assume k <= m <= n
+*
+            CALL CUNGLQ( 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 CUNGLQ( 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 CUNGBR
+*
+      END
diff --git a/SRC/cunghr.f b/SRC/cunghr.f
new file mode 100644
index 00000000..d938d777
--- /dev/null
+++ b/SRC/cunghr.f
@@ -0,0 +1,165 @@
+      SUBROUTINE CUNGHR( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGHR generates a complex unitary matrix Q which is defined as the
+*  product of IHI-ILO elementary reflectors of order N, as returned by
+*  CGEHRD:
+*
+*  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 CGEHRD. 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 array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by CGEHRD.
+*          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 array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEHRD.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LWKOPT, NB, NH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNGQR, 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, 'CUNGQR', ' ', NH, NH, NH, -1 )
+         LWKOPT = MAX( 1, NH )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CUNGHR', -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 CUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
+     $                WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of CUNGHR
+*
+      END
diff --git a/SRC/cungl2.f b/SRC/cungl2.f
new file mode 100644
index 00000000..95ce84f9
--- /dev/null
+++ b/SRC/cungl2.f
@@ -0,0 +1,136 @@
+      SUBROUTINE CUNGL2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGL2 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 CGELQF.
+*
+*  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 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 CGELQF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGELQF.
+*
+*  WORK    (workspace) COMPLEX array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, CSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNGL2', -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 CLACGV( N-I, A( I, I+1 ), LDA )
+            IF( I.LT.M ) THEN
+               A( I, I ) = ONE
+               CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     CONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
+            END IF
+            CALL CSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
+            CALL CLACGV( N-I, A( I, I+1 ), LDA )
+         END IF
+         A( I, I ) = ONE - CONJG( TAU( I ) )
+*
+*        Set A(i,1:i-1,i) to zero
+*
+         DO 30 L = 1, I - 1
+            A( I, L ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of CUNGL2
+*
+      END
diff --git a/SRC/cunglq.f b/SRC/cunglq.f
new file mode 100644
index 00000000..ecd5b65e
--- /dev/null
+++ b/SRC/cunglq.f
@@ -0,0 +1,215 @@
+      SUBROUTINE CUNGLQ( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGLQ 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 CGELQF.
+*
+*  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 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 CGELQF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGELQF.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNGL2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'CUNGLQ', ' ', 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( 'CUNGLQ', -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, 'CUNGLQ', ' ', 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, 'CUNGLQ', ' ', 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 CUNGL2( 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 CLARFT( '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 CLARFB( '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 CUNGL2( 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 CUNGLQ
+*
+      END
diff --git a/SRC/cungql.f b/SRC/cungql.f
new file mode 100644
index 00000000..88252096
--- /dev/null
+++ b/SRC/cungql.f
@@ -0,0 +1,222 @@
+      SUBROUTINE CUNGQL( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGQL 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 CGEQLF.
+*
+*  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 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 CGEQLF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQLF.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
+     $                   NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNG2L, 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, 'CUNGQL', ' ', 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( 'CUNGQL', -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, 'CUNGQL', ' ', 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, 'CUNGQL', ' ', 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 CUNG2L( 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 CLARFT( '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 CLARFB( '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 CUNG2L( 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 CUNGQL
+*
+      END
diff --git a/SRC/cungqr.f b/SRC/cungqr.f
new file mode 100644
index 00000000..b2337287
--- /dev/null
+++ b/SRC/cungqr.f
@@ -0,0 +1,216 @@
+      SUBROUTINE CUNGQR( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGQR 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 CGEQRF.
+*
+*  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 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 CGEQRF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQRF.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNG2R, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'CUNGQR', ' ', 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( 'CUNGQR', -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, 'CUNGQR', ' ', 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, 'CUNGQR', ' ', 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 CUNG2R( 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 CLARFT( '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 CLARFB( '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 CUNG2R( 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 CUNGQR
+*
+      END
diff --git a/SRC/cungr2.f b/SRC/cungr2.f
new file mode 100644
index 00000000..a5f051a9
--- /dev/null
+++ b/SRC/cungr2.f
@@ -0,0 +1,134 @@
+      SUBROUTINE CUNGR2( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGR2 generates an m by n complex 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 CGERQF.
+*
+*  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 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 CGERQF 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) COMPLEX array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGERQF.
+*
+*  WORK    (workspace) COMPLEX array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
+     $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, CSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNGR2', -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
+*
+         CALL CLACGV( N-M+II-1, A( II, 1 ), LDA )
+         A( II, N-M+II ) = ONE
+         CALL CLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
+     $               CONJG( TAU( I ) ), A, LDA, WORK )
+         CALL CSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
+         CALL CLACGV( N-M+II-1, A( II, 1 ), LDA )
+         A( II, N-M+II ) = ONE - CONJG( 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 CUNGR2
+*
+      END
diff --git a/SRC/cungrq.f b/SRC/cungrq.f
new file mode 100644
index 00000000..f40028ef
--- /dev/null
+++ b/SRC/cungrq.f
@@ -0,0 +1,223 @@
+      SUBROUTINE CUNGRQ( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGRQ generates an M-by-N complex 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 CGERQF.
+*
+*  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 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 CGERQF 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) COMPLEX array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGERQF.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNGR2, 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, 'CUNGRQ', ' ', 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( 'CUNGRQ', -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, 'CUNGRQ', ' ', 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, 'CUNGRQ', ' ', 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 CUNGR2( 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 CLARFT( '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 CLARFB( 'Right', 'Conjugate 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 CUNGR2( 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 CUNGRQ
+*
+      END
diff --git a/SRC/cungtr.f b/SRC/cungtr.f
new file mode 100644
index 00000000..4d424928
--- /dev/null
+++ b/SRC/cungtr.f
@@ -0,0 +1,184 @@
+      SUBROUTINE CUNGTR( 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            A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNGTR generates a complex unitary matrix Q which is defined as the
+*  product of n-1 elementary reflectors of order N, as returned by
+*  CHETRD:
+*
+*  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 CHETRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from CHETRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  A       (input/output) COMPLEX array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by CHETRD.
+*          On exit, the N-by-N unitary matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= N.
+*
+*  TAU     (input) COMPLEX array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CHETRD.
+*
+*  WORK    (workspace/output) COMPLEX 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            ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, J, LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNGQL, CUNGQR, 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, 'CUNGQL', ' ', N-1, N-1, N-1, -1 )
+         ELSE
+           NB = ILAENV( 1, 'CUNGQR', ' ', 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( 'CUNGTR', -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 CHETRD 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 CUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to CHETRD 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 CUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                   LWORK, IINFO )
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of CUNGTR
+*
+      END
diff --git a/SRC/cunm2l.f b/SRC/cunm2l.f
new file mode 100644
index 00000000..fb33c410
--- /dev/null
+++ b/SRC/cunm2l.f
@@ -0,0 +1,196 @@
+      SUBROUTINE CUNM2L( 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            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNM2L 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 CGEQLF. 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 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
+*          CGEQLF 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) COMPLEX array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQLF.
+*
+*  C       (input/output) COMPLEX 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, MI, NI, NQ
+      COMPLEX            AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNM2L', -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) or H(i)' is applied to C(1:m-k+i,1:n)
+*
+            MI = M - K + I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,1:n-k+i)
+*
+            NI = N - K + I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = TAU( I )
+         ELSE
+            TAUI = CONJG( TAU( I ) )
+         END IF
+         AII = A( NQ-K+I, I )
+         A( NQ-K+I, I ) = ONE
+         CALL CLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
+         A( NQ-K+I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of CUNM2L
+*
+      END
diff --git a/SRC/cunm2r.f b/SRC/cunm2r.f
new file mode 100644
index 00000000..d54a1b2b
--- /dev/null
+++ b/SRC/cunm2r.f
@@ -0,0 +1,201 @@
+      SUBROUTINE CUNM2R( 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            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNM2R 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 CGEQRF. 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 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
+*          CGEQRF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQRF.
+*
+*  C       (input/output) COMPLEX 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      COMPLEX            AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNM2R', -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 = CONJG( TAU( I ) )
+         END IF
+         AII = A( I, I )
+         A( I, I ) = ONE
+         CALL CLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
+     $               WORK )
+         A( I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of CUNM2R
+*
+      END
diff --git a/SRC/cunmbr.f b/SRC/cunmbr.f
new file mode 100644
index 00000000..6212f125
--- /dev/null
+++ b/SRC/cunmbr.f
@@ -0,0 +1,289 @@
+      SUBROUTINE CUNMBR( 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            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  If VECT = 'Q', CUNMBR 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', CUNMBR 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 CGEBRD 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 CGEBRD.
+*          If VECT = 'P', the number of rows in the original
+*          matrix reduced by CGEBRD.
+*          K >= 0.
+*
+*  A       (input) COMPLEX 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 CGEBRD.
+*
+*  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 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 CGEBRD in the array argument TAUQ or TAUP.
+*
+*  C       (input/output) COMPLEX 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 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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNMLQ, CUNMQR, 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( 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, 'CUNMQR', SIDE // TRANS, M-1, N, M-1,
+     $                         -1 )
+               ELSE
+                  NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M, N-1, N-1,
+     $                         -1 )
+               END IF
+            ELSE
+               IF( LEFT ) THEN
+                  NB = ILAENV( 1, 'CUNMLQ', SIDE // TRANS, M-1, N, M-1,
+     $                         -1 )
+               ELSE
+                  NB = ILAENV( 1, 'CUNMLQ', 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( 'CUNMBR', -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 CGEBRD with nq >= k
+*
+            CALL CUNMQR( 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 CGEBRD 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 CUNMQR( 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 CGEBRD with nq > k
+*
+            CALL CUNMLQ( 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 CGEBRD 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 CUNMLQ( 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 CUNMBR
+*
+      END
diff --git a/SRC/cunmhr.f b/SRC/cunmhr.f
new file mode 100644
index 00000000..11646ef5
--- /dev/null
+++ b/SRC/cunmhr.f
@@ -0,0 +1,202 @@
+      SUBROUTINE CUNMHR( 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 ..
+      COMPLEX            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMHR 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 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 CGEHRD:
+*
+*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  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': apply Q  (No transpose)
+*          = 'C': apply Q**H (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.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI must have the same values as in the previous call
+*          of CGEHRD. 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) COMPLEX array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by CGEHRD.
+*
+*  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) COMPLEX 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 CGEHRD.
+*
+*  C       (input/output) COMPLEX 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 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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNMQR, 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, 'C' ) )
+     $          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, 'CUNMQR', SIDE // TRANS, NH, N, NH, -1 )
+         ELSE
+            NB = ILAENV( 1, 'CUNMQR', 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( 'CUNMHR', -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 CUNMQR( 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 CUNMHR
+*
+      END
diff --git a/SRC/cunml2.f b/SRC/cunml2.f
new file mode 100644
index 00000000..09a5ad0e
--- /dev/null
+++ b/SRC/cunml2.f
@@ -0,0 +1,205 @@
+      SUBROUTINE CUNML2( 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            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNML2 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 CGELQF. 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 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
+*          CGELQF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGELQF.
+*
+*  C       (input/output) COMPLEX 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      COMPLEX            AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNML2', -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 = CONJG( TAU( I ) )
+         ELSE
+            TAUI = TAU( I )
+         END IF
+         IF( I.LT.NQ )
+     $      CALL CLACGV( NQ-I, A( I, I+1 ), LDA )
+         AII = A( I, I )
+         A( I, I ) = ONE
+         CALL CLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
+     $               LDC, WORK )
+         A( I, I ) = AII
+         IF( I.LT.NQ )
+     $      CALL CLACGV( NQ-I, A( I, I+1 ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of CUNML2
+*
+      END
diff --git a/SRC/cunmlq.f b/SRC/cunmlq.f
new file mode 100644
index 00000000..cc2018de
--- /dev/null
+++ b/SRC/cunmlq.f
@@ -0,0 +1,268 @@
+      SUBROUTINE CUNMLQ( 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            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMLQ 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 CGELQF. 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 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
+*          CGELQF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGELQF.
+*
+*  C       (input/output) COMPLEX 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 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            T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNML2, 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, '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, 'CUNMLQ', SIDE // TRANS, M, N, K,
+     $             -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CUNMLQ', -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, 'CUNMLQ', 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 CUNML2( 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 CLARFT( '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 CLARFB( 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 CUNMLQ
+*
+      END
diff --git a/SRC/cunmql.f b/SRC/cunmql.f
new file mode 100644
index 00000000..eeb23422
--- /dev/null
+++ b/SRC/cunmql.f
@@ -0,0 +1,262 @@
+      SUBROUTINE CUNMQL( 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            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMQL 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 CGEQLF. 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':  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 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
+*          CGEQLF 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) COMPLEX array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQLF.
+*
+*  C       (input/output) COMPLEX 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 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 ..
+      COMPLEX            T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNM2L, 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, '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.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, 'CUNMQL', 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( 'CUNMQL', -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, 'CUNMQL', 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 CUNM2L( 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 CLARFT( '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 CLARFB( 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 CUNMQL
+*
+      END
diff --git a/SRC/cunmqr.f b/SRC/cunmqr.f
new file mode 100644
index 00000000..152c4c5d
--- /dev/null
+++ b/SRC/cunmqr.f
@@ -0,0 +1,261 @@
+      SUBROUTINE CUNMQR( 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            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMQR 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 CGEQRF. 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 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
+*          CGEQRF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGEQRF.
+*
+*  C       (input/output) COMPLEX 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 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            T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNM2R, 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, '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, 'CUNMQR', SIDE // TRANS, M, N, K,
+     $        -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CUNMQR', -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, 'CUNMQR', 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 CUNM2R( 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 CLARFT( '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 CLARFB( 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 CUNMQR
+*
+      END
diff --git a/SRC/cunmr2.f b/SRC/cunmr2.f
new file mode 100644
index 00000000..3dc0cb47
--- /dev/null
+++ b/SRC/cunmr2.f
@@ -0,0 +1,198 @@
+      SUBROUTINE CUNMR2( 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            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMR2 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 CGERQF. 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 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
+*          CGERQF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGERQF.
+*
+*  C       (input/output) COMPLEX 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 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, MI, NI, NQ
+      COMPLEX            AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLACGV, CLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNMR2', -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) or H(i)' is applied to C(1:m-k+i,1:n)
+*
+            MI = M - K + I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,1:n-k+i)
+*
+            NI = N - K + I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = CONJG( TAU( I ) )
+         ELSE
+            TAUI = TAU( I )
+         END IF
+         CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
+         AII = A( I, NQ-K+I )
+         A( I, NQ-K+I ) = ONE
+         CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK )
+         A( I, NQ-K+I ) = AII
+         CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of CUNMR2
+*
+      END
diff --git a/SRC/cunmr3.f b/SRC/cunmr3.f
new file mode 100644
index 00000000..3660fbac
--- /dev/null
+++ b/SRC/cunmr3.f
@@ -0,0 +1,212 @@
+      SUBROUTINE CUNMR3( 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            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMR3 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 CTZRZF. 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 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
+*          CTZRZF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CTZRZF.
+*
+*  C       (input/output) COMPLEX 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 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            TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARZ, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, 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( 'CUNMR3', -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 = CONJG( TAU( I ) )
+         END IF
+         CALL CLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAUI,
+     $               C( IC, JC ), LDC, WORK )
+*
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of CUNMR3
+*
+      END
diff --git a/SRC/cunmrq.f b/SRC/cunmrq.f
new file mode 100644
index 00000000..e8a83f17
--- /dev/null
+++ b/SRC/cunmrq.f
@@ -0,0 +1,269 @@
+      SUBROUTINE CUNMRQ( 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            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMRQ 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 CGERQF. 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':  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 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
+*          CGERQF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CGERQF.
+*
+*  C       (input/output) COMPLEX 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 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 ..
+      COMPLEX            T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARFB, CLARFT, CUNMR2, 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, '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.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, 'CUNMRQ', 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( 'CUNMRQ', -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, 'CUNMRQ', 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 CUNMR2( 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 = '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 CLARFT( '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 CLARFB( 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 CUNMRQ
+*
+      END
diff --git a/SRC/cunmrz.f b/SRC/cunmrz.f
new file mode 100644
index 00000000..041043cc
--- /dev/null
+++ b/SRC/cunmrz.f
@@ -0,0 +1,297 @@
+      SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, L, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMRZ 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 CTZRZF. 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 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
+*          CTZRZF 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 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CTZRZF.
+*
+*  C       (input/output) COMPLEX 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 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            T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARZB, CLARZT, CUNMR3, 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, '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
+         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, 'CUNMRQ', 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( 'CUNMRZ', -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, 'CUNMRQ', 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, 'CUNMRQ', 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 CUNMR3( 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 CLARZT( '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 CLARZB( 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 CUNMRZ
+*
+      END
diff --git a/SRC/cunmtr.f b/SRC/cunmtr.f
new file mode 100644
index 00000000..3c601975
--- /dev/null
+++ b/SRC/cunmtr.f
@@ -0,0 +1,223 @@
+      SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, 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, UPLO
+      INTEGER            INFO, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUNMTR 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 of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by CHETRD:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangle of A contains elementary reflectors
+*                 from CHETRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from CHETRD.
+*
+*  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.
+*
+*  A       (input) COMPLEX array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by CHETRD.
+*
+*  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) COMPLEX 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 CHETRD.
+*
+*  C       (input/output) COMPLEX 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 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, UPPER
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNMQL, CUNMQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( UPPER ) THEN
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'CUNMQL', SIDE // TRANS, M-1, N, M-1,
+     $                      -1 )
+            ELSE
+               NB = ILAENV( 1, 'CUNMQL', SIDE // TRANS, M, N-1, N-1,
+     $                      -1 )
+            END IF
+         ELSE
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'CUNMQR', SIDE // TRANS, M-1, N, M-1,
+     $                      -1 )
+            ELSE
+               NB = ILAENV( 1, 'CUNMQR', 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( 'CUNMTR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( LEFT ) THEN
+         MI = M - 1
+         NI = N
+      ELSE
+         MI = M
+         NI = N - 1
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to CHETRD with UPLO = 'U'
+*
+         CALL CUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
+     $                LDC, WORK, LWORK, IINFO )
+      ELSE
+*
+*        Q was determined by a call to CHETRD with UPLO = 'L'
+*
+         IF( LEFT ) THEN
+            I1 = 2
+            I2 = 1
+         ELSE
+            I1 = 1
+            I2 = 2
+         END IF
+         CALL CUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+     $                C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of CUNMTR
+*
+      END
diff --git a/SRC/cupgtr.f b/SRC/cupgtr.f
new file mode 100644
index 00000000..490b5c15
--- /dev/null
+++ b/SRC/cupgtr.f
@@ -0,0 +1,161 @@
+      SUBROUTINE CUPGTR( 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 ..
+      COMPLEX            AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUPGTR generates a complex unitary matrix Q which is defined as the
+*  product of n-1 elementary reflectors H(i) of order n, as returned by
+*  CHPTRD 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 CHPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to CHPTRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
+*          The vectors which define the elementary reflectors, as
+*          returned by CHPTRD.
+*
+*  TAU     (input) COMPLEX array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CHPTRD.
+*
+*  Q       (output) COMPLEX array, dimension (LDQ,N)
+*          The N-by-N unitary matrix Q.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX array, dimension (N-1)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX            CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
+     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IINFO, IJ, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CUNG2L, CUNG2R, 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( 'CUPGTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to CHPTRD 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 ) = CZERO
+   20    CONTINUE
+         DO 30 I = 1, N - 1
+            Q( I, N ) = CZERO
+   30    CONTINUE
+         Q( N, N ) = CONE
+*
+*        Generate Q(1:n-1,1:n-1)
+*
+         CALL CUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to CHPTRD 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 ) = CONE
+         DO 40 I = 2, N
+            Q( I, 1 ) = CZERO
+   40    CONTINUE
+         IJ = 3
+         DO 60 J = 2, N
+            Q( 1, J ) = CZERO
+            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 CUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
+     $                   IINFO )
+         END IF
+      END IF
+      RETURN
+*
+*     End of CUPGTR
+*
+      END
diff --git a/SRC/cupmtr.f b/SRC/cupmtr.f
new file mode 100644
index 00000000..de09b783
--- /dev/null
+++ b/SRC/cupmtr.f
@@ -0,0 +1,267 @@
+      SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, 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, UPLO
+      INTEGER            INFO, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX            AP( * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  CUPMTR 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 of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by CHPTRD using packed
+*  storage:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangular packed storage used in previous
+*                 call to CHPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to CHPTRD.
+*
+*  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.
+*
+*  AP      (input) COMPLEX array, dimension
+*                               (M*(M+1)/2) if SIDE = 'L'
+*                               (N*(N+1)/2) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by CHPTRD.  AP is modified by the routine but
+*          restored on exit.
+*
+*  TAU     (input) COMPLEX array, dimension (M-1) if SIDE = 'L'
+*                                     or (N-1) if SIDE = 'R'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by CHPTRD.
+*
+*  C       (input/output) COMPLEX 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) COMPLEX 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            ONE
+      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORWRD, LEFT, NOTRAN, UPPER
+      INTEGER            I, I1, I2, I3, IC, II, JC, MI, NI, NQ
+      COMPLEX            AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           CLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'CUPMTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to CHPTRD with UPLO = 'U'
+*
+         FORWRD = ( LEFT .AND. NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. .NOT.NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+         ELSE
+            MI = M
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IF( LEFT ) THEN
+*
+*              H(i) or H(i)' is applied to C(1:i,1:n)
+*
+               MI = I
+            ELSE
+*
+*              H(i) or H(i)' is applied to C(1:m,1:i)
+*
+               NI = I
+            END IF
+*
+*           Apply H(i) or H(i)'
+*
+            IF( NOTRAN ) THEN
+               TAUI = TAU( I )
+            ELSE
+               TAUI = CONJG( TAU( I ) )
+            END IF
+            AII = AP( II )
+            AP( II ) = ONE
+            CALL CLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC,
+     $                  WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + I + 2
+            ELSE
+               II = II - I - 1
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Q was determined by a call to CHPTRD with UPLO = 'L'.
+*
+         FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         DO 20 I = I1, I2, I3
+            AII = AP( II )
+            AP( II ) = ONE
+            IF( LEFT ) THEN
+*
+*              H(i) or H(i)' is applied to C(i+1:m,1:n)
+*
+               MI = M - I
+               IC = I + 1
+            ELSE
+*
+*              H(i) or H(i)' is applied to C(1:m,i+1:n)
+*
+               NI = N - I
+               JC = I + 1
+            END IF
+*
+*           Apply H(i) or H(i)'
+*
+            IF( NOTRAN ) THEN
+               TAUI = TAU( I )
+            ELSE
+               TAUI = CONJG( TAU( I ) )
+            END IF
+            CALL CLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ),
+     $                  LDC, WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + NQ - I + 1
+            ELSE
+               II = II - NQ + I - 2
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of CUPMTR
+*
+      END
diff --git a/SRC/dbdsdc.f b/SRC/dbdsdc.f
new file mode 100644
index 00000000..2bd3de62
--- /dev/null
+++ b/SRC/dbdsdc.f
@@ -0,0 +1,429 @@
+      SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, UPLO
+      INTEGER            INFO, LDU, LDVT, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IQ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), Q( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DBDSDC computes the singular value decomposition (SVD) of a real
+*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
+*  using a divide and conquer method, where S is a diagonal matrix
+*  with non-negative diagonal elements (the singular values of B), and
+*  U and VT are orthogonal matrices of left and right singular vectors,
+*  respectively. DBDSDC can be used to compute all singular values,
+*  and optionally, singular vectors or singular vectors in compact form.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.  See DLASD3 for details.
+*
+*  The code currently calls DLASDQ if singular values only are desired.
+*  However, it can be slightly modified to compute singular values
+*  using the divide and conquer method.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  B is upper bidiagonal.
+*          = 'L':  B is lower bidiagonal.
+*
+*  COMPQ   (input) CHARACTER*1
+*          Specifies whether singular vectors are to be computed
+*          as follows:
+*          = 'N':  Compute singular values only;
+*          = 'P':  Compute singular values and compute singular
+*                  vectors in compact form;
+*          = 'I':  Compute singular values and singular vectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrix B.  N >= 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.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the elements of E contain the offdiagonal
+*          elements of the bidiagonal matrix whose SVD is desired.
+*          On exit, E has been destroyed.
+*
+*  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
+*          If  COMPQ = 'I', then:
+*             On exit, if INFO = 0, U contains the left singular vectors
+*             of the bidiagonal matrix.
+*          For other values of COMPQ, U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1.
+*          If singular vectors are desired, then LDU >= max( 1, N ).
+*
+*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
+*          If  COMPQ = 'I', then:
+*             On exit, if INFO = 0, VT' contains the right singular
+*             vectors of the bidiagonal matrix.
+*          For other values of COMPQ, VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1.
+*          If singular vectors are desired, then LDVT >= max( 1, N ).
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ)
+*          If  COMPQ = 'P', then:
+*             On exit, if INFO = 0, Q and IQ contain the left
+*             and right singular vectors in a compact form,
+*             requiring O(N log N) space instead of 2*N**2.
+*             In particular, Q contains all the DOUBLE PRECISION data in
+*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
+*             words of memory, where SMLSIZ is returned by ILAENV and
+*             is equal to the maximum size of the subproblems at the
+*             bottom of the computation tree (usually about 25).
+*          For other values of COMPQ, Q is not referenced.
+*
+*  IQ      (output) INTEGER array, dimension (LDIQ)
+*          If  COMPQ = 'P', then:
+*             On exit, if INFO = 0, Q and IQ contain the left
+*             and right singular vectors in a compact form,
+*             requiring O(N log N) space instead of 2*N**2.
+*             In particular, IQ contains all INTEGER data in
+*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
+*             words of memory, where SMLSIZ is returned by ILAENV and
+*             is equal to the maximum size of the subproblems at the
+*             bottom of the computation tree (usually about 25).
+*          For other values of COMPQ, IQ is not referenced.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          If COMPQ = 'N' then LWORK >= (4 * N).
+*          If COMPQ = 'P' then LWORK >= (6 * N).
+*          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
+*
+*  IWORK   (workspace) INTEGER array, dimension (8*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an singular value.
+*                The update process of divide and conquer failed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*  Changed dimension statement in comment describing E from (N) to
+*  (N-1).  Sven, 17 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
+     $                   ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
+     $                   MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
+     $                   SMLSZP, SQRE, START, WSTART, Z
+      DOUBLE PRECISION   CS, EPS, ORGNRM, P, R, SN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ,
+     $                   DLASET, DLASR, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IUPLO = 0
+      IF( LSAME( UPLO, 'U' ) )
+     $   IUPLO = 1
+      IF( LSAME( UPLO, 'L' ) )
+     $   IUPLO = 2
+      IF( LSAME( COMPQ, 'N' ) ) THEN
+         ICOMPQ = 0
+      ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
+         ICOMPQ = 1
+      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+         ICOMPQ = 2
+      ELSE
+         ICOMPQ = -1
+      END IF
+      IF( IUPLO.EQ.0 ) THEN
+         INFO = -1
+      ELSE IF( ICOMPQ.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
+     $         N ) ) ) THEN
+         INFO = -7
+      ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
+     $         N ) ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DBDSDC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPQ.EQ.1 ) THEN
+            Q( 1 ) = SIGN( ONE, D( 1 ) )
+            Q( 1+SMLSIZ*N ) = ONE
+         ELSE IF( ICOMPQ.EQ.2 ) THEN
+            U( 1, 1 ) = SIGN( ONE, D( 1 ) )
+            VT( 1, 1 ) = ONE
+         END IF
+         D( 1 ) = ABS( D( 1 ) )
+         RETURN
+      END IF
+      NM1 = N - 1
+*
+*     If matrix lower bidiagonal, rotate to be upper bidiagonal
+*     by applying Givens rotations on the left
+*
+      WSTART = 1
+      QSTART = 3
+      IF( ICOMPQ.EQ.1 ) THEN
+         CALL DCOPY( N, D, 1, Q( 1 ), 1 )
+         CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )
+      END IF
+      IF( IUPLO.EQ.2 ) THEN
+         QSTART = 5
+         WSTART = 2*N - 1
+         DO 10 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( ICOMPQ.EQ.1 ) THEN
+               Q( I+2*N ) = CS
+               Q( I+3*N ) = SN
+            ELSE IF( ICOMPQ.EQ.2 ) THEN
+               WORK( I ) = CS
+               WORK( NM1+I ) = -SN
+            END IF
+   10    CONTINUE
+      END IF
+*
+*     If ICOMPQ = 0, use DLASDQ to compute the singular values.
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+         CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
+     $                LDU, WORK( WSTART ), INFO )
+         GO TO 40
+      END IF
+*
+*     If N is smaller than the minimum divide size SMLSIZ, then solve
+*     the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         IF( ICOMPQ.EQ.2 ) THEN
+            CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
+            CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+            CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
+     $                   LDU, WORK( WSTART ), INFO )
+         ELSE IF( ICOMPQ.EQ.1 ) THEN
+            IU = 1
+            IVT = IU + N
+            CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
+     $                   N )
+            CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
+     $                   N )
+            CALL DLASDQ( 'U', 0, N, N, N, 0, D, E,
+     $                   Q( IVT+( QSTART-1 )*N ), N,
+     $                   Q( IU+( QSTART-1 )*N ), N,
+     $                   Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
+     $                   INFO )
+         END IF
+         GO TO 40
+      END IF
+*
+      IF( ICOMPQ.EQ.2 ) THEN
+         CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
+         CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+      END IF
+*
+*     Scale.
+*
+      ORGNRM = DLANST( 'M', N, D, E )
+      IF( ORGNRM.EQ.ZERO )
+     $   RETURN
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
+*
+      EPS = DLAMCH( 'Epsilon' )
+*
+      MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+      SMLSZP = SMLSIZ + 1
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         IU = 1
+         IVT = 1 + SMLSIZ
+         DIFL = IVT + SMLSZP
+         DIFR = DIFL + MLVL
+         Z = DIFR + MLVL*2
+         IC = Z + MLVL
+         IS = IC + 1
+         POLES = IS + 1
+         GIVNUM = POLES + 2*MLVL
+*
+         K = 1
+         GIVPTR = 2
+         PERM = 3
+         GIVCOL = PERM + MLVL
+      END IF
+*
+      DO 20 I = 1, N
+         IF( ABS( D( I ) ).LT.EPS ) THEN
+            D( I ) = SIGN( EPS, D( I ) )
+         END IF
+   20 CONTINUE
+*
+      START = 1
+      SQRE = 0
+*
+      DO 30 I = 1, NM1
+         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+*
+*        Subproblem found. First determine its size and then
+*        apply divide and conquer on it.
+*
+            IF( I.LT.NM1 ) THEN
+*
+*        A subproblem with E(I) small for I < NM1.
+*
+               NSIZE = I - START + 1
+            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+*        A subproblem with E(NM1) not too small but I = NM1.
+*
+               NSIZE = N - START + 1
+            ELSE
+*
+*        A subproblem with E(NM1) small. This implies an
+*        1-by-1 subproblem at D(N). Solve this 1-by-1 problem
+*        first.
+*
+               NSIZE = I - START + 1
+               IF( ICOMPQ.EQ.2 ) THEN
+                  U( N, N ) = SIGN( ONE, D( N ) )
+                  VT( N, N ) = ONE
+               ELSE IF( ICOMPQ.EQ.1 ) THEN
+                  Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
+                  Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
+               END IF
+               D( N ) = ABS( D( N ) )
+            END IF
+            IF( ICOMPQ.EQ.2 ) THEN
+               CALL DLASD0( NSIZE, SQRE, D( START ), E( START ),
+     $                      U( START, START ), LDU, VT( START, START ),
+     $                      LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
+            ELSE
+               CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
+     $                      E( START ), Q( START+( IU+QSTART-2 )*N ), N,
+     $                      Q( START+( IVT+QSTART-2 )*N ),
+     $                      IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
+     $                      N ), Q( START+( DIFR+QSTART-2 )*N ),
+     $                      Q( START+( Z+QSTART-2 )*N ),
+     $                      Q( START+( POLES+QSTART-2 )*N ),
+     $                      IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
+     $                      N, IQ( START+PERM*N ),
+     $                      Q( START+( GIVNUM+QSTART-2 )*N ),
+     $                      Q( START+( IC+QSTART-2 )*N ),
+     $                      Q( START+( IS+QSTART-2 )*N ),
+     $                      WORK( WSTART ), IWORK, INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+            END IF
+            START = I + 1
+         END IF
+   30 CONTINUE
+*
+*     Unscale
+*
+      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
+   40 CONTINUE
+*
+*     Use Selection Sort to minimize swaps of singular vectors
+*
+      DO 60 II = 2, N
+         I = II - 1
+         KK = I
+         P = D( I )
+         DO 50 J = II, N
+            IF( D( J ).GT.P ) THEN
+               KK = J
+               P = D( J )
+            END IF
+   50    CONTINUE
+         IF( KK.NE.I ) THEN
+            D( KK ) = D( I )
+            D( I ) = P
+            IF( ICOMPQ.EQ.1 ) THEN
+               IQ( I ) = KK
+            ELSE IF( ICOMPQ.EQ.2 ) THEN
+               CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
+               CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
+            END IF
+         ELSE IF( ICOMPQ.EQ.1 ) THEN
+            IQ( I ) = I
+         END IF
+   60 CONTINUE
+*
+*     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         IF( IUPLO.EQ.1 ) THEN
+            IQ( N ) = 1
+         ELSE
+            IQ( N ) = 0
+         END IF
+      END IF
+*
+*     If B is lower bidiagonal, update U by those Givens rotations
+*     which rotated B to be upper bidiagonal
+*
+      IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
+     $   CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
+*
+      RETURN
+*
+*     End of DBDSDC
+*
+      END
diff --git a/SRC/dbdsqr.f b/SRC/dbdsqr.f
new file mode 100644
index 00000000..60245862
--- /dev/null
+++ b/SRC/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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. 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)) 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/ddisna.f b/SRC/ddisna.f
new file mode 100644
index 00000000..2d9ed334
--- /dev/null
+++ b/SRC/ddisna.f
@@ -0,0 +1,179 @@
+      SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB
+      INTEGER            INFO, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), SEP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DDISNA computes the reciprocal condition numbers for the eigenvectors
+*  of a real symmetric or complex Hermitian matrix or for the left or
+*  right singular vectors of a general m-by-n matrix. The reciprocal
+*  condition number is the 'gap' between the corresponding eigenvalue or
+*  singular value and the nearest other one.
+*
+*  The bound on the error, measured by angle in radians, in the I-th
+*  computed vector is given by
+*
+*         DLAMCH( 'E' ) * ( ANORM / SEP( I ) )
+*
+*  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed
+*  to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of
+*  the error bound.
+*
+*  DDISNA may also be used to compute error bounds for eigenvectors of
+*  the generalized symmetric definite eigenproblem.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies for which problem the reciprocal condition numbers
+*          should be computed:
+*          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;
+*          = 'L':  the left singular vectors of a general matrix;
+*          = 'R':  the right singular vectors of a general matrix.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix. M >= 0.
+*
+*  N       (input) INTEGER
+*          If JOB = 'L' or 'R', the number of columns of the matrix,
+*          in which case N >= 0. Ignored if JOB = 'E'.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
+*                              dimension (min(M,N)) if JOB = 'L' or 'R'
+*          The eigenvalues (if JOB = 'E') or singular values (if JOB =
+*          'L' or 'R') of the matrix, in either increasing or decreasing
+*          order. If singular values, they must be non-negative.
+*
+*  SEP     (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
+*                               dimension (min(M,N)) if JOB = 'L' or 'R'
+*          The reciprocal condition numbers of the vectors.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DECR, EIGEN, INCR, LEFT, RIGHT, SING
+      INTEGER            I, K
+      DOUBLE PRECISION   ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      EIGEN = LSAME( JOB, 'E' )
+      LEFT = LSAME( JOB, 'L' )
+      RIGHT = LSAME( JOB, 'R' )
+      SING = LEFT .OR. RIGHT
+      IF( EIGEN ) THEN
+         K = M
+      ELSE IF( SING ) THEN
+         K = MIN( M, N )
+      END IF
+      IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 ) THEN
+         INFO = -3
+      ELSE
+         INCR = .TRUE.
+         DECR = .TRUE.
+         DO 10 I = 1, K - 1
+            IF( INCR )
+     $         INCR = INCR .AND. D( I ).LE.D( I+1 )
+            IF( DECR )
+     $         DECR = DECR .AND. D( I ).GE.D( I+1 )
+   10    CONTINUE
+         IF( SING .AND. K.GT.0 ) THEN
+            IF( INCR )
+     $         INCR = INCR .AND. ZERO.LE.D( 1 )
+            IF( DECR )
+     $         DECR = DECR .AND. D( K ).GE.ZERO
+         END IF
+         IF( .NOT.( INCR .OR. DECR ) )
+     $      INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DDISNA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 )
+     $   RETURN
+*
+*     Compute reciprocal condition numbers
+*
+      IF( K.EQ.1 ) THEN
+         SEP( 1 ) = DLAMCH( 'O' )
+      ELSE
+         OLDGAP = ABS( D( 2 )-D( 1 ) )
+         SEP( 1 ) = OLDGAP
+         DO 20 I = 2, K - 1
+            NEWGAP = ABS( D( I+1 )-D( I ) )
+            SEP( I ) = MIN( OLDGAP, NEWGAP )
+            OLDGAP = NEWGAP
+   20    CONTINUE
+         SEP( K ) = OLDGAP
+      END IF
+      IF( SING ) THEN
+         IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
+            IF( INCR )
+     $         SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
+            IF( DECR )
+     $         SEP( K ) = MIN( SEP( K ), D( K ) )
+         END IF
+      END IF
+*
+*     Ensure that reciprocal condition numbers are not less than
+*     threshold, in order to limit the size of the error bound
+*
+      EPS = DLAMCH( 'E' )
+      SAFMIN = DLAMCH( 'S' )
+      ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
+      IF( ANORM.EQ.ZERO ) THEN
+         THRESH = EPS
+      ELSE
+         THRESH = MAX( EPS*ANORM, SAFMIN )
+      END IF
+      DO 30 I = 1, K
+         SEP( I ) = MAX( SEP( I ), THRESH )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of DDISNA
+*
+      END
diff --git a/SRC/dgbbrd.f b/SRC/dgbbrd.f
new file mode 100644
index 00000000..5b8f06fb
--- /dev/null
+++ b/SRC/dgbbrd.f
@@ -0,0 +1,443 @@
+      SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
+     $                   LDQ, PT, LDPT, C, LDC, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),
+     $                   PT( LDPT, * ), Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBBRD reduces a real general m-by-n band matrix A to upper
+*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+*  The routine computes B, and optionally forms Q or P', or computes
+*  Q'*C for a given matrix C.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          Specifies whether or not the matrices Q and P' are to be
+*          formed.
+*          = 'N': do not form Q or P';
+*          = 'Q': form Q only;
+*          = 'P': form P' only;
+*          = 'B': form both.
+*
+*  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.
+*
+*  NCC     (input) INTEGER
+*          The number of columns of the matrix C.  NCC >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals of the matrix A. KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals of the matrix A. KU >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the m-by-n band matrix A, stored in rows 1 to
+*          KL+KU+1. The j-th column of A is stored in the j-th column of
+*          the array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*          On exit, A is overwritten by values generated during the
+*          reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A. LDAB >= KL+KU+1.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B.
+*
+*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+*          The superdiagonal elements of the bidiagonal matrix B.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,M)
+*          If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
+*          If VECT = 'N' or 'P', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
+*
+*  PT      (output) DOUBLE PRECISION array, dimension (LDPT,N)
+*          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
+*          If VECT = 'N' or 'Q', the array PT is not referenced.
+*
+*  LDPT    (input) INTEGER
+*          The leading dimension of the array PT.
+*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)
+*          On entry, an m-by-ncc matrix C.
+*          On exit, C is overwritten by Q'*C.
+*          C is not referenced if NCC = 0.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C.
+*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*max(M,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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTB, WANTC, WANTPT, WANTQ
+      INTEGER            I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
+     $                   KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
+      DOUBLE PRECISION   RA, RB, RC, RS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTB = LSAME( VECT, 'B' )
+      WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
+      WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
+      WANTC = NCC.GT.0
+      KLU1 = KL + KU + 1
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KLU1 ) THEN
+         INFO = -8
+      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
+         INFO = -12
+      ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBBRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and P' to the unit matrix, if needed
+*
+      IF( WANTQ )
+     $   CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
+      IF( WANTPT )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      MINMN = MIN( M, N )
+*
+      IF( KL+KU.GT.1 ) THEN
+*
+*        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
+*        first to lower bidiagonal form and then transform to upper
+*        bidiagonal
+*
+         IF( KU.GT.0 ) THEN
+            ML0 = 1
+            MU0 = 2
+         ELSE
+            ML0 = 2
+            MU0 = 1
+         END IF
+*
+*        Wherever possible, plane rotations are generated and applied in
+*        vector operations of length NR over the index set J1:J2:KLU1.
+*
+*        The sines of the plane rotations are stored in WORK(1:max(m,n))
+*        and the cosines in WORK(max(m,n)+1:2*max(m,n)).
+*
+         MN = MAX( M, N )
+         KLM = MIN( M-1, KL )
+         KUN = MIN( N-1, KU )
+         KB = KLM + KUN
+         KB1 = KB + 1
+         INCA = KB1*LDAB
+         NR = 0
+         J1 = KLM + 2
+         J2 = 1 - KUN
+*
+         DO 90 I = 1, MINMN
+*
+*           Reduce i-th column and i-th row of matrix to bidiagonal form
+*
+            ML = KLM + 1
+            MU = KUN + 1
+            DO 80 KK = 1, KB
+               J1 = J1 + KB
+               J2 = J2 + KB
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been created below the band
+*
+               IF( NR.GT.0 )
+     $            CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
+     $                         WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
+*
+*              apply plane rotations from the left
+*
+               DO 10 L = 1, KB
+                  IF( J2-KLM+L-1.GT.N ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
+     $                            AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
+     $                            WORK( MN+J1 ), WORK( J1 ), KB1 )
+   10          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  IF( ML.LE.M-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i+ml-1,i)
+*                    within the band, and apply rotation from the left
+*
+                     CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
+     $                            WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
+     $                            RA )
+                     AB( KU+ML-1, I ) = RA
+                     IF( I.LT.N )
+     $                  CALL DROT( MIN( KU+ML-2, N-I ),
+     $                             AB( KU+ML-2, I+1 ), LDAB-1,
+     $                             AB( KU+ML-1, I+1 ), LDAB-1,
+     $                             WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTQ ) THEN
+*
+*                 accumulate product of plane rotations in Q
+*
+                  DO 20 J = J1, J2, KB1
+                     CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                          WORK( MN+J ), WORK( J ) )
+   20             CONTINUE
+               END IF
+*
+               IF( WANTC ) THEN
+*
+*                 apply plane rotations to C
+*
+                  DO 30 J = J1, J2, KB1
+                     CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
+     $                          WORK( MN+J ), WORK( J ) )
+   30             CONTINUE
+               END IF
+*
+               IF( J2+KUN.GT.N ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 40 J = J1, J2, KB1
+*
+*                 create nonzero element a(j-1,j+ku) above the band
+*                 and store it in WORK(n+1:2*n)
+*
+                  WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
+                  AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
+   40          CONTINUE
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been generated above the band
+*
+               IF( NR.GT.0 )
+     $            CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
+     $                         WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
+     $                         KB1 )
+*
+*              apply plane rotations from the right
+*
+               DO 50 L = 1, KB
+                  IF( J2+L-1.GT.M ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
+     $                            AB( L, J1+KUN ), INCA,
+     $                            WORK( MN+J1+KUN ), WORK( J1+KUN ),
+     $                            KB1 )
+   50          CONTINUE
+*
+               IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
+                  IF( MU.LE.N-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i,i+mu-1)
+*                    within the band, and apply rotation from the right
+*
+                     CALL DLARTG( AB( KU-MU+3, I+MU-2 ),
+     $                            AB( KU-MU+2, I+MU-1 ),
+     $                            WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
+     $                            RA )
+                     AB( KU-MU+3, I+MU-2 ) = RA
+                     CALL DROT( MIN( KL+MU-2, M-I ),
+     $                          AB( KU-MU+4, I+MU-2 ), 1,
+     $                          AB( KU-MU+3, I+MU-1 ), 1,
+     $                          WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTPT ) THEN
+*
+*                 accumulate product of plane rotations in P'
+*
+                  DO 60 J = J1, J2, KB1
+                     CALL DROT( N, PT( J+KUN-1, 1 ), LDPT,
+     $                          PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),
+     $                          WORK( J+KUN ) )
+   60             CONTINUE
+               END IF
+*
+               IF( J2+KB.GT.M ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 70 J = J1, J2, KB1
+*
+*                 create nonzero element a(j+kl+ku,j+ku-1) below the
+*                 band and store it in WORK(1:n)
+*
+                  WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
+                  AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
+   70          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  ML = ML - 1
+               ELSE
+                  MU = MU - 1
+               END IF
+   80       CONTINUE
+   90    CONTINUE
+      END IF
+*
+      IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
+*
+*        A has been reduced to lower bidiagonal form
+*
+*        Transform lower bidiagonal form to upper bidiagonal by applying
+*        plane rotations from the left, storing diagonal elements in D
+*        and off-diagonal elements in E
+*
+         DO 100 I = 1, MIN( M-1, N )
+            CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
+            D( I ) = RA
+            IF( I.LT.N ) THEN
+               E( I ) = RS*AB( 1, I+1 )
+               AB( 1, I+1 ) = RC*AB( 1, I+1 )
+            END IF
+            IF( WANTQ )
+     $         CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
+            IF( WANTC )
+     $         CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
+     $                    RS )
+  100    CONTINUE
+         IF( M.LE.N )
+     $      D( M ) = AB( 1, M )
+      ELSE IF( KU.GT.0 ) THEN
+*
+*        A has been reduced to upper bidiagonal form
+*
+         IF( M.LT.N ) THEN
+*
+*           Annihilate a(m,m+1) by applying plane rotations from the
+*           right, storing diagonal elements in D and off-diagonal
+*           elements in E
+*
+            RB = AB( KU, M+1 )
+            DO 110 I = M, 1, -1
+               CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA )
+               D( I ) = RA
+               IF( I.GT.1 ) THEN
+                  RB = -RS*AB( KU, I )
+                  E( I-1 ) = RC*AB( KU, I )
+               END IF
+               IF( WANTPT )
+     $            CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
+     $                       RC, RS )
+  110       CONTINUE
+         ELSE
+*
+*           Copy off-diagonal elements to E and diagonal elements to D
+*
+            DO 120 I = 1, MINMN - 1
+               E( I ) = AB( KU, I+1 )
+  120       CONTINUE
+            DO 130 I = 1, MINMN
+               D( I ) = AB( KU+1, I )
+  130       CONTINUE
+         END IF
+      ELSE
+*
+*        A is diagonal. Set elements of E to zero and copy diagonal
+*        elements to D.
+*
+         DO 140 I = 1, MINMN - 1
+            E( I ) = ZERO
+  140    CONTINUE
+         DO 150 I = 1, MINMN
+            D( I ) = AB( 1, I )
+  150    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DGBBRD
+*
+      END
diff --git a/SRC/dgbcon.f b/SRC/dgbcon.f
new file mode 100644
index 00000000..b75d6784
--- /dev/null
+++ b/SRC/dgbcon.f
@@ -0,0 +1,226 @@
+      SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, 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          NORM
+      INTEGER            INFO, KL, KU, LDAB, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBCON estimates the reciprocal of the condition number of a real
+*  general band matrix A, in either the 1-norm or the infinity-norm,
+*  using the LU factorization computed by DGBTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by DGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= N, row i of the matrix was
+*          interchanged with row IPIV(i).
+*
+*  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 (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            LNOTI, ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, J, JP, KASE, KASE1, KD, LM
+      DOUBLE PRECISION   AINVNM, SCALE, SMLNUM, T
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DDOT, DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DLACN2, DLATBS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the norm of inv(A).
+*
+      AINVNM = ZERO
+      NORMIN = 'N'
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KD = KL + KU + 1
+      LNOTI = KL.GT.0
+      KASE = 0
+   10 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            IF( LNOTI ) THEN
+               DO 20 J = 1, N - 1
+                  LM = MIN( KL, N-J )
+                  JP = IPIV( J )
+                  T = WORK( JP )
+                  IF( JP.NE.J ) THEN
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+                  CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
+   20          CONTINUE
+            END IF
+*
+*           Multiply by inv(U).
+*
+            CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+     $                   INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+     $                   INFO )
+*
+*           Multiply by inv(L').
+*
+            IF( LNOTI ) THEN
+               DO 30 J = N - 1, 1, -1
+                  LM = MIN( KL, N-J )
+                  WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1,
+     $                        WORK( J+1 ), 1 )
+                  JP = IPIV( J )
+                  IF( JP.NE.J ) THEN
+                     T = WORK( JP )
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+   30          CONTINUE
+            END IF
+         END IF
+*
+*        Divide X by 1/SCALE if doing so will not cause overflow.
+*
+         NORMIN = 'Y'
+         IF( SCALE.NE.ONE ) THEN
+            IX = IDAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 40
+            CALL DRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of DGBCON
+*
+      END
diff --git a/SRC/dgbequ.f b/SRC/dgbequ.f
new file mode 100644
index 00000000..e813761f
--- /dev/null
+++ b/SRC/dgbequ.f
@@ -0,0 +1,239 @@
+      SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, 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, KL, KU, LDAB, M, N
+      DOUBLE PRECISION   AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBEQU computes row and column scalings intended to equilibrate an
+*  M-by-N band matrix A and reduce its condition number.  R returns the
+*  row scale factors and C the column scale factors, chosen to try to
+*  make the largest element in each row and column of the matrix B with
+*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+*  number and BIGNUM = largest safe number.  Use of these scaling
+*  factors is not guaranteed to reduce the condition number of A but
+*  works well in practice.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  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, KD
+      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         ROWCND = ONE
+         COLCND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+*     Compute row scale factors.
+*
+      DO 10 I = 1, M
+         R( I ) = ZERO
+   10 CONTINUE
+*
+*     Find the maximum element in each row.
+*
+      KD = KU + 1
+      DO 30 J = 1, N
+         DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 40 I = 1, M
+         RCMAX = MAX( RCMAX, R( I ) )
+         RCMIN = MIN( RCMIN, R( I ) )
+   40 CONTINUE
+      AMAX = RCMAX
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 50 I = 1, M
+            IF( R( I ).EQ.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   50    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 60 I = 1, M
+            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+   60    CONTINUE
+*
+*        Compute ROWCND = min(R(I)) / max(R(I))
+*
+         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+*     Compute column scale factors
+*
+      DO 70 J = 1, N
+         C( J ) = ZERO
+   70 CONTINUE
+*
+*     Find the maximum element in each column,
+*     assuming the row scaling computed above.
+*
+      KD = KU + 1
+      DO 90 J = 1, N
+         DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 100 J = 1, N
+         RCMIN = MIN( RCMIN, C( J ) )
+         RCMAX = MAX( RCMAX, C( J ) )
+  100 CONTINUE
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 110 J = 1, N
+            IF( C( J ).EQ.ZERO ) THEN
+               INFO = M + J
+               RETURN
+            END IF
+  110    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 120 J = 1, N
+            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+  120    CONTINUE
+*
+*        Compute COLCND = min(C(J)) / max(C(J))
+*
+         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+      RETURN
+*
+*     End of DGBEQU
+*
+      END
diff --git a/SRC/dgbrfs.f b/SRC/dgbrfs.f
new file mode 100644
index 00000000..c466f5a7
--- /dev/null
+++ b/SRC/dgbrfs.f
@@ -0,0 +1,355 @@
+      SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   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, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is banded, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The original band matrix A, stored in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by DGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from DGBTRF; 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 DGBTRS.
+*          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, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGBMV, DGBTRS, DLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -9
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( KL+KU+2, N+1 )
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,
+     $               ONE, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               KK = KU + 1 - K
+               XK = ABS( X( K, J ) )
+               DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               KK = KU + 1 - K
+               DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                   WORK( N+1 ), N, INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**T).
+*
+               CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  120          CONTINUE
+               CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DGBRFS
+*
+      END
diff --git a/SRC/dgbsv.f b/SRC/dgbsv.f
new file mode 100644
index 00000000..1629ec79
--- /dev/null
+++ b/SRC/dgbsv.f
@@ -0,0 +1,142 @@
+      SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBSV computes the solution to a real system of linear equations
+*  A * X = B, where A is a band matrix of order N with KL subdiagonals
+*  and KU superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  The LU decomposition with partial pivoting and row interchanges is
+*  used to factor A as A = L * U, where L is a product of permutation
+*  and unit lower triangular matrices with KL subdiagonals, and U is
+*  upper triangular with KL+KU superdiagonals.  The factored form of A
+*  is then used to solve the system of equations A * X = B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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 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, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           DGBTRF, DGBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of the band matrix A.
+*
+      CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
+     $                B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of DGBSV
+*
+      END
diff --git a/SRC/dgbsvx.f b/SRC/dgbsvx.f
new file mode 100644
index 00000000..a329ec22
--- /dev/null
+++ b/SRC/dgbsvx.f
@@ -0,0 +1,513 @@
+      SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
+     $                   LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, TRANS
+      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBSVX uses the LU factorization to compute the solution to a real
+*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+*  where A is a band matrix of order N with KL subdiagonals and KU
+*  superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed by this subroutine:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
+*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+*     or diag(C)*B (if TRANS = 'T' or 'C').
+*
+*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+*     matrix A (after equilibration if FACT = 'E') as
+*        A = L * U,
+*     where L is a product of permutation and unit lower triangular
+*     matrices with KL subdiagonals, and U is upper triangular with
+*     KL+KU superdiagonals.
+*
+*  3. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+*     that it solves the original system before equilibration.
+*
+*  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, AFB and IPIV contain the factored form of
+*                  A.  If EQUED is not 'N', the matrix A has been
+*                  equilibrated with scaling factors given by R and C.
+*                  AB, AFB, and IPIV are not modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
+*
+*          If FACT = 'F' and EQUED is not 'N', then A must have been
+*          equilibrated by the scaling factors in R and/or C.  AB is not
+*          modified if FACT = 'F' or 'N', or if FACT = 'E' and
+*          EQUED = 'N' on exit.
+*
+*          On exit, if EQUED .ne. 'N', A is scaled as follows:
+*          EQUED = 'R':  A := diag(R) * A
+*          EQUED = 'C':  A := A * diag(C)
+*          EQUED = 'B':  A := diag(R) * A * diag(C).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains details of the LU factorization of the band matrix
+*          A, as computed by DGBTRF.  U is stored as an upper triangular
+*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
+*          and the multipliers used during the factorization are stored
+*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is
+*          the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns details of the LU factorization of A.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns details of the LU factorization of the equilibrated
+*          matrix A (see the description of AB for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.
+*
+*  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 = L*U
+*          as computed by DGBTRF; row i of the matrix was interchanged
+*          with row IPIV(i).
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the original matrix A.
+*
+*          If FACT = 'E', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the equilibrated matrix A.
+*
+*  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 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 (3*N)
+*          On exit, WORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If WORK(1) is much less than 1, then the stability
+*          of the LU factorization of the (equilibrated) matrix A
+*          could be poor. This also means that the solution X, condition
+*          estimator RCOND, and forward error bound FERR could be
+*          unreliable. If factorization fails with 0<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, J1, J2
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANGB, DLANTB
+      EXTERNAL           LSAME, DLAMCH, DLANGB, DLANTB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS,
+     $                   DLACPY, DLAQGB, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         ROWEQU = .FALSE.
+         COLEQU = .FALSE.
+      ELSE
+         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -8
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -10
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -12
+      ELSE
+         IF( ROWEQU ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 10 J = 1, N
+               RCMIN = MIN( RCMIN, R( J ) )
+               RCMAX = MAX( RCMAX, R( J ) )
+   10       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -13
+            ELSE IF( N.GT.0 ) THEN
+               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               ROWCND = ONE
+            END IF
+         END IF
+         IF( COLEQU .AND. INFO.EQ.0 ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 20 J = 1, N
+               RCMIN = MIN( RCMIN, C( J ) )
+               RCMAX = MAX( RCMAX, C( J ) )
+   20       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -14
+            ELSE IF( N.GT.0 ) THEN
+               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               COLCND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -16
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -18
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                   AMAX, EQUED )
+            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( NOTRAN ) THEN
+         IF( ROWEQU ) THEN
+            DO 40 J = 1, NRHS
+               DO 30 I = 1, N
+                  B( I, J ) = R( I )*B( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( COLEQU ) THEN
+         DO 60 J = 1, NRHS
+            DO 50 I = 1, N
+               B( I, J ) = C( I )*B( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the LU factorization of the band matrix A.
+*
+         DO 70 J = 1, N
+            J1 = MAX( J-KU, 1 )
+            J2 = MIN( J+KL, N )
+            CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
+     $                  AFB( KL+KU+1-J+J1, J ), 1 )
+   70    CONTINUE
+*
+         CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 ) THEN
+*
+*           Compute the reciprocal pivot growth factor of the
+*           leading rank-deficient INFO columns of A.
+*
+            ANORM = ZERO
+            DO 90 J = 1, INFO
+               DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+                  ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
+   80          CONTINUE
+   90       CONTINUE
+            RPVGRW = DLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
+     $                       AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
+     $                       WORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = ANORM / RPVGRW
+            END IF
+            WORK( 1 ) = RPVGRW
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A and the
+*     reciprocal pivot growth factor RPVGRW.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
+      RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
+     $             WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( NOTRAN ) THEN
+         IF( COLEQU ) THEN
+            DO 110 J = 1, NRHS
+               DO 100 I = 1, N
+                  X( I, J ) = C( I )*X( I, J )
+  100          CONTINUE
+  110       CONTINUE
+            DO 120 J = 1, NRHS
+               FERR( J ) = FERR( J ) / COLCND
+  120       CONTINUE
+         END IF
+      ELSE IF( ROWEQU ) THEN
+         DO 140 J = 1, NRHS
+            DO 130 I = 1, N
+               X( I, J ) = R( I )*X( I, J )
+  130       CONTINUE
+  140    CONTINUE
+         DO 150 J = 1, NRHS
+            FERR( J ) = FERR( J ) / ROWCND
+  150    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of DGBSVX
+*
+      END
diff --git a/SRC/dgbtf2.f b/SRC/dgbtf2.f
new file mode 100644
index 00000000..929829e8
--- /dev/null
+++ b/SRC/dgbtf2.f
@@ -0,0 +1,202 @@
+      SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBTF2 computes an LU factorization of a real m-by-n band matrix A
+*  using partial pivoting with row interchanges.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U, because of fill-in resulting from the row
+*  interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JP, JU, KM, KV
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      EXTERNAL           IDAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in.
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Gaussian elimination with partial pivoting
+*
+*     Set fill-in elements in columns KU+2 to KV to zero.
+*
+      DO 20 J = KU + 2, MIN( KV, N )
+         DO 10 I = KV - J + 2, KL
+            AB( I, J ) = ZERO
+   10    CONTINUE
+   20 CONTINUE
+*
+*     JU is the index of the last column affected by the current stage
+*     of the factorization.
+*
+      JU = 1
+*
+      DO 40 J = 1, MIN( M, N )
+*
+*        Set fill-in elements in column J+KV to zero.
+*
+         IF( J+KV.LE.N ) THEN
+            DO 30 I = 1, KL
+               AB( I, J+KV ) = ZERO
+   30       CONTINUE
+         END IF
+*
+*        Find pivot and test for singularity. KM is the number of
+*        subdiagonal elements in the current column.
+*
+         KM = MIN( KL, M-J )
+         JP = IDAMAX( KM+1, AB( KV+1, J ), 1 )
+         IPIV( J ) = JP + J - 1
+         IF( AB( KV+JP, J ).NE.ZERO ) THEN
+            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
+*
+*           Apply interchange to columns J to JU.
+*
+            IF( JP.NE.1 )
+     $         CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
+     $                     AB( KV+1, J ), LDAB-1 )
+*
+            IF( KM.GT.0 ) THEN
+*
+*              Compute multipliers.
+*
+               CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
+*
+*              Update trailing submatrix within the band.
+*
+               IF( JU.GT.J )
+     $            CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
+     $                       AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
+     $                       LDAB-1 )
+            END IF
+         ELSE
+*
+*           If pivot is zero, set INFO to the index of the pivot
+*           unless a zero pivot has already been found.
+*
+            IF( INFO.EQ.0 )
+     $         INFO = J
+         END IF
+   40 CONTINUE
+      RETURN
+*
+*     End of DGBTF2
+*
+      END
diff --git a/SRC/dgbtrf.f b/SRC/dgbtrf.f
new file mode 100644
index 00000000..b22fc065
--- /dev/null
+++ b/SRC/dgbtrf.f
@@ -0,0 +1,441 @@
+      SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBTRF computes an LU factorization of a real m-by-n band matrix A
+*  using partial pivoting with row interchanges.
+*
+*  This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
+     $                   JU, K2, KM, KV, NB, NW
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   WORK13( LDWORK, NBMAX ),
+     $                   WORK31( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX, ILAENV
+      EXTERNAL           IDAMAX, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL,
+     $                   DSWAP, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment
+*
+      NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU )
+*
+*     The block size must not exceed the limit set by the size of the
+*     local arrays WORK13 and WORK31.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
+*
+*        Use unblocked code
+*
+         CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+*        Zero the superdiagonal elements of the work array WORK13
+*
+         DO 20 J = 1, NB
+            DO 10 I = 1, J - 1
+               WORK13( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+*
+*        Zero the subdiagonal elements of the work array WORK31
+*
+         DO 40 J = 1, NB
+            DO 30 I = J + 1, NB
+               WORK31( I, J ) = ZERO
+   30       CONTINUE
+   40    CONTINUE
+*
+*        Gaussian elimination with partial pivoting
+*
+*        Set fill-in elements in columns KU+2 to KV to zero
+*
+         DO 60 J = KU + 2, MIN( KV, N )
+            DO 50 I = KV - J + 2, KL
+               AB( I, J ) = ZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+*        JU is the index of the last column affected by the current
+*        stage of the factorization
+*
+         JU = 1
+*
+         DO 180 J = 1, MIN( M, N ), NB
+            JB = MIN( NB, MIN( M, N )-J+1 )
+*
+*           The active part of the matrix is partitioned
+*
+*              A11   A12   A13
+*              A21   A22   A23
+*              A31   A32   A33
+*
+*           Here A11, A21 and A31 denote the current block of JB columns
+*           which is about to be factorized. The number of rows in the
+*           partitioning are JB, I2, I3 respectively, and the numbers
+*           of columns are JB, J2, J3. The superdiagonal elements of A13
+*           and the subdiagonal elements of A31 lie outside the band.
+*
+            I2 = MIN( KL-JB, M-J-JB+1 )
+            I3 = MIN( JB, M-J-KL+1 )
+*
+*           J2 and J3 are computed after JU has been updated.
+*
+*           Factorize the current block of JB columns
+*
+            DO 80 JJ = J, J + JB - 1
+*
+*              Set fill-in elements in column JJ+KV to zero
+*
+               IF( JJ+KV.LE.N ) THEN
+                  DO 70 I = 1, KL
+                     AB( I, JJ+KV ) = ZERO
+   70             CONTINUE
+               END IF
+*
+*              Find pivot and test for singularity. KM is the number of
+*              subdiagonal elements in the current column.
+*
+               KM = MIN( KL, M-JJ )
+               JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 )
+               IPIV( JJ ) = JP + JJ - J
+               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
+                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
+                  IF( JP.NE.1 ) THEN
+*
+*                    Apply interchange to columns J to J+JB-1
+*
+                     IF( JP+JJ-1.LT.J+KL ) THEN
+*
+                        CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              AB( KV+JP+JJ-J, J ), LDAB-1 )
+                     ELSE
+*
+*                       The interchange affects columns J to JJ-1 of A31
+*                       which are stored in the work array WORK31
+*
+                        CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                        CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
+     $                              AB( KV+JP, JJ ), LDAB-1 )
+                     END IF
+                  END IF
+*
+*                 Compute multipliers
+*
+                  CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
+     $                        1 )
+*
+*                 Update trailing submatrix within the band and within
+*                 the current block. JM is the index of the last column
+*                 which needs to be updated.
+*
+                  JM = MIN( JU, J+JB-1 )
+                  IF( JM.GT.JJ )
+     $               CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
+     $                          AB( KV, JJ+1 ), LDAB-1,
+     $                          AB( KV+1, JJ+1 ), LDAB-1 )
+               ELSE
+*
+*                 If pivot is zero, set INFO to the index of the pivot
+*                 unless a zero pivot has already been found.
+*
+                  IF( INFO.EQ.0 )
+     $               INFO = JJ
+               END IF
+*
+*              Copy current column of A31 into the work array WORK31
+*
+               NW = MIN( JJ-J+1, I3 )
+               IF( NW.GT.0 )
+     $            CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
+     $                        WORK31( 1, JJ-J+1 ), 1 )
+   80       CONTINUE
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply the row interchanges to the other blocks.
+*
+               J2 = MIN( JU-J+1, KV ) - JB
+               J3 = MAX( 0, JU-J-KV+1 )
+*
+*              Use DLASWP to apply the row interchanges to A12, A22, and
+*              A32.
+*
+               CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
+     $                      IPIV( J ), 1 )
+*
+*              Adjust the pivot indices.
+*
+               DO 90 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+   90          CONTINUE
+*
+*              Apply the row interchanges to A13, A23, and A33
+*              columnwise.
+*
+               K2 = J - 1 + JB + J2
+               DO 110 I = 1, J3
+                  JJ = K2 + I
+                  DO 100 II = J + I - 1, J + JB - 1
+                     IP = IPIV( II )
+                     IF( IP.NE.II ) THEN
+                        TEMP = AB( KV+1+II-JJ, JJ )
+                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
+                        AB( KV+1+IP-JJ, JJ ) = TEMP
+                     END IF
+  100             CONTINUE
+  110          CONTINUE
+*
+*              Update the relevant part of the trailing submatrix
+*
+               IF( J2.GT.0 ) THEN
+*
+*                 Update A12
+*
+                  CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,
+     $                        AB( KV+1-JB, J+JB ), LDAB-1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A22
+*
+                     CALL DGEMM( 'No transpose', 'No transpose', I2, J2,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+1, J+JB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A32
+*
+                     CALL DGEMM( 'No transpose', 'No transpose', I3, J2,
+     $                           JB, -ONE, WORK31, LDWORK,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
+                  END IF
+               END IF
+*
+               IF( J3.GT.0 ) THEN
+*
+*                 Copy the lower triangle of A13 into the work array
+*                 WORK13
+*
+                  DO 130 JJ = 1, J3
+                     DO 120 II = JJ, JB
+                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
+  120                CONTINUE
+  130             CONTINUE
+*
+*                 Update A13 in the work array
+*
+                  CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,
+     $                        WORK13, LDWORK )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A23
+*
+                     CALL DGEMM( 'No transpose', 'No transpose', I2, J3,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
+     $                           LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A33
+*
+                     CALL DGEMM( 'No transpose', 'No transpose', I3, J3,
+     $                           JB, -ONE, WORK31, LDWORK, WORK13,
+     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
+                  END IF
+*
+*                 Copy the lower triangle of A13 back into place
+*
+                  DO 150 JJ = 1, J3
+                     DO 140 II = JJ, JB
+                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
+  140                CONTINUE
+  150             CONTINUE
+               END IF
+            ELSE
+*
+*              Adjust the pivot indices.
+*
+               DO 160 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+  160          CONTINUE
+            END IF
+*
+*           Partially undo the interchanges in the current block to
+*           restore the upper triangular form of A31 and copy the upper
+*           triangle of A31 back into place
+*
+            DO 170 JJ = J + JB - 1, J, -1
+               JP = IPIV( JJ ) - JJ + 1
+               IF( JP.NE.1 ) THEN
+*
+*                 Apply interchange to columns J to JJ-1
+*
+                  IF( JP+JJ-1.LT.J+KL ) THEN
+*
+*                    The interchange does not affect A31
+*
+                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )
+                  ELSE
+*
+*                    The interchange does affect A31
+*
+                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                  END IF
+               END IF
+*
+*              Copy the current column of A31 back into place
+*
+               NW = MIN( I3, JJ-J+1 )
+               IF( NW.GT.0 )
+     $            CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
+     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )
+  170       CONTINUE
+  180    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DGBTRF
+*
+      END
diff --git a/SRC/dgbtrs.f b/SRC/dgbtrs.f
new file mode 100644
index 00000000..c7ade372
--- /dev/null
+++ b/SRC/dgbtrs.f
@@ -0,0 +1,186 @@
+      SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGBTRS solves a system of linear equations
+*     A * X = B  or  A' * X = B
+*  with a general band matrix A using the LU factorization computed
+*  by DGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by DGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; 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            LNOTI, NOTRAN
+      INTEGER            I, J, KD, L, LM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER, DSWAP, DTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      KD = KU + KL + 1
+      LNOTI = KL.GT.0
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve  A*X = B.
+*
+*        Solve L*X = B, overwriting B with X.
+*
+*        L is represented as a product of permutations and unit lower
+*        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
+*        where each transformation L(i) is a rank-one modification of
+*        the identity matrix.
+*
+         IF( LNOTI ) THEN
+            DO 10 J = 1, N - 1
+               LM = MIN( KL, N-J )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+               CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
+     $                    LDB, B( J+1, 1 ), LDB )
+   10       CONTINUE
+         END IF
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
+     $                  AB, LDAB, B( 1, I ), 1 )
+   20    CONTINUE
+*
+      ELSE
+*
+*        Solve A'*X = B.
+*
+         DO 30 I = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
+     $                  LDAB, B( 1, I ), 1 )
+   30    CONTINUE
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         IF( LNOTI ) THEN
+            DO 40 J = N - 1, 1, -1
+               LM = MIN( KL, N-J )
+               CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
+     $                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of DGBTRS
+*
+      END
diff --git a/SRC/dgebak.f b/SRC/dgebak.f
new file mode 100644
index 00000000..b8e9be56
--- /dev/null
+++ b/SRC/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/dgebal.f b/SRC/dgebal.f
new file mode 100644
index 00000000..1796577b
--- /dev/null
+++ b/SRC/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/dgebd2.f b/SRC/dgebd2.f
new file mode 100644
index 00000000..b9eb6387
--- /dev/null
+++ b/SRC/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/dgebrd.f b/SRC/dgebrd.f
new file mode 100644
index 00000000..6544715d
--- /dev/null
+++ b/SRC/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/dgecon.f b/SRC/dgecon.f
new file mode 100644
index 00000000..807cafca
--- /dev/null
+++ b/SRC/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/dgeequ.f b/SRC/dgeequ.f
new file mode 100644
index 00000000..b703116e
--- /dev/null
+++ b/SRC/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/dgees.f b/SRC/dgees.f
new file mode 100644
index 00000000..96ba8019
--- /dev/null
+++ b/SRC/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/dgeesx.f b/SRC/dgeesx.f
new file mode 100644
index 00000000..deb30ab2
--- /dev/null
+++ b/SRC/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/dgeev.f b/SRC/dgeev.f
new file mode 100644
index 00000000..50e08a9c
--- /dev/null
+++ b/SRC/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/dgeevx.f b/SRC/dgeevx.f
new file mode 100644
index 00000000..7d927ae9
--- /dev/null
+++ b/SRC/dgeevx.f
@@ -0,0 +1,556 @@
+      SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
+     $                   VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
+     $                   RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
+      DOUBLE PRECISION   ABNRM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), RCONDE( * ), RCONDV( * ),
+     $                   SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WI( * ), WORK( * ), WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
+*  eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+*  Optionally also, it computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
+*  (RCONDE), and reciprocal condition numbers for the right
+*  eigenvectors (RCONDV).
+*
+*  The right eigenvector v(j) of A satisfies
+*                   A * v(j) = lambda(j) * v(j)
+*  where lambda(j) is its eigenvalue.
+*  The left eigenvector u(j) of A satisfies
+*                u(j)**H * A = lambda(j) * u(j)**H
+*  where u(j)**H denotes the conjugate transpose of u(j).
+*
+*  The computed eigenvectors are normalized to have Euclidean norm
+*  equal to 1 and largest component real.
+*
+*  Balancing a matrix means permuting the rows and columns to make it
+*  more nearly upper triangular, and applying a diagonal similarity
+*  transformation D * A * D**(-1), where D is a diagonal matrix, to
+*  make its rows and columns closer in norm and the condition numbers
+*  of its eigenvalues and eigenvectors smaller.  The computed
+*  reciprocal condition numbers correspond to the balanced matrix.
+*  Permuting rows and columns will not change the condition numbers
+*  (in exact arithmetic) but diagonal scaling will.  For further
+*  explanation of balancing, see section 4.10.2 of the LAPACK
+*  Users' Guide.
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Indicates how the input matrix should be diagonally scaled
+*          and/or permuted to improve the conditioning of its
+*          eigenvalues.
+*          = 'N': Do not diagonally scale or permute;
+*          = 'P': Perform permutations to make the matrix more nearly
+*                 upper triangular. Do not diagonally scale;
+*          = 'S': Diagonally scale the matrix, i.e. replace A by
+*                 D*A*D**(-1), where D is a diagonal matrix chosen
+*                 to make the rows and columns of A more equal in
+*                 norm. Do not permute;
+*          = 'B': Both diagonally scale and permute A.
+*
+*          Computed reciprocal condition numbers will be for the matrix
+*          after balancing and/or permuting. Permuting does not change
+*          condition numbers (in exact arithmetic), but balancing does.
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N': left eigenvectors of A are not computed;
+*          = 'V': left eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVL must = 'V'.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N': right eigenvectors of A are not computed;
+*          = 'V': right eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVR must = 'V'.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': None are computed;
+*          = 'E': Computed for eigenvalues only;
+*          = 'V': Computed for right eigenvectors only;
+*          = 'B': Computed for eigenvalues and right eigenvectors.
+*
+*          If SENSE = 'E' or 'B', both left and right eigenvectors
+*          must also be computed (JOBVL = 'V' and JOBVR = 'V').
+*
+*  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.  If JOBVL = 'V' or
+*          JOBVR = 'V', A contains the real Schur form of the balanced
+*          version of the input matrix A.
+*
+*  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 will 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, and if
+*          JOBVR = 'V', LDVR >= N.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values determined when A was
+*          balanced.  The balanced A(i,j) = 0 if I > J and
+*          J = 1,...,ILO-1 or I = IHI+1,...,N.
+*
+*  SCALE   (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          when balancing A.  If P(j) is the index of the row and column
+*          interchanged with row and column j, and D(j) is the scaling
+*          factor applied to row and column j, then
+*          SCALE(J) = P(J),    for J = 1,...,ILO-1
+*                   = D(J),    for J = ILO,...,IHI
+*                   = P(J)     for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) DOUBLE PRECISION
+*          The one-norm of the balanced matrix (the maximum
+*          of the sum of absolute values of elements of any column).
+*
+*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)
+*          RCONDE(j) is the reciprocal condition number of the j-th
+*          eigenvalue.
+*
+*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)
+*          RCONDV(j) is the reciprocal condition number of the j-th
+*          right eigenvector.
+*
+*  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 SENSE = 'N' or 'E',
+*          LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
+*          LWORK >= 3*N.  If SENSE = 'V' or 'B', LWORK >= N*(N+6).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*N-2)
+*          If SENSE = 'N' or 'E', not referenced.
+*
+*  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 or condition numbers
+*                have been computed; elements 1:ILO-1 and 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, WNTSNB, WNTSNE,
+     $                   WNTSNN, WNTSNV
+      CHARACTER          JOB, SIDE
+      INTEGER            HSWORK, I, ICOND, IERR, 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,
+     $                   DTRSNA, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX, ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE, DLAPY2, DNRM2
+      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2,
+     $                   DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVL = LSAME( JOBVL, 'V' )
+      WANTVR = LSAME( JOBVR, 'V' )
+      WNTSNN = LSAME( SENSE, 'N' )
+      WNTSNE = LSAME( SENSE, 'E' )
+      WNTSNV = LSAME( SENSE, 'V' )
+      WNTSNB = LSAME( SENSE, 'B' )
+      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
+     $    'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
+     $         ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
+     $         WANTVR ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -11
+      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -13
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by DHSEQR, as
+*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+*       the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+*
+            IF( WANTVL ) THEN
+               CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+     $                WORK, -1, INFO )
+            ELSE IF( WANTVR ) THEN
+               CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+     $                WORK, -1, INFO )
+            ELSE
+               IF( WNTSNN ) THEN
+                  CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
+     $                LDVR, WORK, -1, INFO )
+               ELSE
+                  CALL DHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
+     $                LDVR, WORK, -1, INFO )
+               END IF
+            END IF
+            HSWORK = WORK( 1 )
+*
+            IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+               MINWRK = 2*N
+               IF( .NOT.WNTSNN )
+     $            MINWRK = MAX( MINWRK, N*N+6*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               IF( .NOT.WNTSNN )
+     $            MAXWRK = MAX( MAXWRK, N*N + 6*N )
+            ELSE
+               MINWRK = 3*N
+               IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+     $            MINWRK = MAX( MINWRK, N*N + 6*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'DORGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+     $            MAXWRK = MAX( MAXWRK, N*N + 6*N )
+               MAXWRK = MAX( MAXWRK, 3*N )
+            END IF
+            MAXWRK = MAX( MAXWRK, MINWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -21
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ICOND = 0
+      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+      SCALEA = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = SMLNUM
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = BIGNUM
+      END IF
+      IF( SCALEA )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix and compute ABNRM
+*
+      CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
+      ABNRM = DLANGE( '1', N, N, A, LDA, DUM )
+      IF( SCALEA ) THEN
+         DUM( 1 ) = ABNRM
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+         ABNRM = DUM( 1 )
+      END IF
+*
+*     Reduce to upper Hessenberg form
+*     (Workspace: need 2*N, prefer N+N*NB)
+*
+      ITAU = 1
+      IWRK = ITAU + N
+      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVL ) THEN
+*
+*        Want left eigenvectors
+*        Copy Householder vectors to VL
+*
+         SIDE = 'L'
+         CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+*        Generate orthogonal matrix in VL
+*        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+         CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VL
+*        (Workspace: need 1, prefer HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+         IF( WANTVR ) THEN
+*
+*           Want left and right eigenvectors
+*           Copy Schur vectors to VR
+*
+            SIDE = 'B'
+            CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+*        Generate orthogonal matrix in VR
+*        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+         CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VR
+*        (Workspace: need 1, prefer HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+      ELSE
+*
+*        Compute eigenvalues only
+*        If condition numbers desired, compute Schur form
+*
+         IF( WNTSNN ) THEN
+            JOB = 'E'
+         ELSE
+            JOB = 'S'
+         END IF
+*
+*        (Workspace: need 1, prefer HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL DHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 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 3*N)
+*
+         CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                N, NOUT, WORK( IWRK ), IERR )
+      END IF
+*
+*     Compute condition numbers if desired
+*     (Workspace: need N*N+6*N unless SENSE = 'E')
+*
+      IF( .NOT.WNTSNN ) THEN
+         CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
+     $                ICOND )
+      END IF
+*
+      IF( WANTVL ) THEN
+*
+*        Undo balancing of left eigenvectors
+*
+         CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
+     $                IERR )
+*
+*        Normalize left eigenvectors and make largest component real
+*
+         DO 20 I = 1, N
+            IF( WI( I ).EQ.ZERO ) THEN
+               SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ),
+     $               DNRM2( N, VL( 1, I+1 ), 1 ) )
+               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
+               DO 10 K = 1, N
+                  WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
+   10          CONTINUE
+               K = IDAMAX( N, WORK, 1 )
+               CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+               CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+               VL( K, I+1 ) = ZERO
+            END IF
+   20    CONTINUE
+      END IF
+*
+      IF( WANTVR ) THEN
+*
+*        Undo balancing of right eigenvectors
+*
+         CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
+     $                IERR )
+*
+*        Normalize right eigenvectors and make largest component real
+*
+         DO 40 I = 1, N
+            IF( WI( I ).EQ.ZERO ) THEN
+               SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ),
+     $               DNRM2( N, VR( 1, I+1 ), 1 ) )
+               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
+               DO 30 K = 1, N
+                  WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
+   30          CONTINUE
+               K = IDAMAX( N, WORK, 1 )
+               CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+               CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
+               VR( K, I+1 ) = ZERO
+            END IF
+   40    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+   50 CONTINUE
+      IF( SCALEA ) THEN
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.EQ.0 ) THEN
+            IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
+     $         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
+     $                      IERR )
+         ELSE
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+     $                   IERR )
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+     $                   IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of DGEEVX
+*
+      END
diff --git a/SRC/dgegs.f b/SRC/dgegs.f
new file mode 100644
index 00000000..85c32531
--- /dev/null
+++ b/SRC/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/dgegv.f b/SRC/dgegv.f
new file mode 100644
index 00000000..282fdb99
--- /dev/null
+++ b/SRC/dgegv.f
@@ -0,0 +1,665 @@
+      SUBROUTINE DGEGV( 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
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine DGGEV.
+*
+*  DGEGV computes the eigenvalues and, optionally, the left and/or right
+*  eigenvectors of a real matrix pair (A,B).
+*  Given two square matrices A and B,
+*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
+*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such
+*  that
+*
+*     A*x = lambda*B*x.
+*
+*  An alternate form is to find the eigenvalues mu and corresponding
+*  eigenvectors y such that
+*
+*     mu*A*y = B*y.
+*
+*  These two forms are equivalent with mu = 1/lambda and x = y if
+*  neither lambda nor mu is zero.  In order to deal with the case that
+*  lambda or mu is zero or small, two values alpha and beta are returned
+*  for each eigenvalue, such that lambda = alpha/beta and
+*  mu = beta/alpha.
+*
+*  The vectors x and y in the above equations are right eigenvectors of
+*  the matrix pair (A,B).  Vectors u and v satisfying
+*
+*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B
+*
+*  are left eigenvectors of (A,B).
+*
+*  Note: this routine performs "full balancing" on A and B -- see
+*  "Further Details", below.
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N':  do not compute the left generalized eigenvectors;
+*          = 'V':  compute the left generalized eigenvectors (returned
+*                  in VL).
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N':  do not compute the right generalized eigenvectors;
+*          = 'V':  compute the right generalized eigenvectors (returned
+*                  in VR).
+*
+*  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.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit A
+*          contains the real Schur form of A from the generalized Schur
+*          factorization of the pair (A,B) after balancing.
+*          If no eigenvectors were computed, then only the diagonal
+*          blocks from the Schur form will be correct.  See DGGHRD and
+*          DHGEQZ for details.
+*
+*  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.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
+*          upper triangular matrix obtained from B in the generalized
+*          Schur factorization of the pair (A,B) after balancing.
+*          If no eigenvectors were computed, then only those elements of
+*          B corresponding to the diagonal blocks from the Schur form of
+*          A will be correct.  See DGGHRD and DHGEQZ for details.
+*
+*  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.
+*
+*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored
+*          in the columns of VL, in the same order as their eigenvalues.
+*          If the j-th eigenvalue is real, then u(j) = VL(:,j).
+*          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).
+*
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvectors
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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 x(j) are stored
+*          in the columns of VR, in the same order as their eigenvalues.
+*          If the j-th eigenvalue is real, then x(j) = VR(:,j).
+*          If the j-th and (j+1)-st eigenvalues form a complex conjugate
+*          pair, then
+*            x(j) = VR(:,j) + i*VR(:,j+1)
+*          and
+*            x(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvalues
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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.
+*          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 + MAX( 6*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.  No eigenvectors have been
+*                calculated, 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 DTGEVC
+*                =N+8: error return from DGGBAK (computing VL)
+*                =N+9: error return from DGGBAK (computing VR)
+*                =N+10: error return from DLASCL (various calls)
+*
+*  Further Details
+*  ===============
+*
+*  Balancing
+*  ---------
+*
+*  This driver calls DGGBAL to both permute and scale rows and columns
+*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
+*  and PL*B*R will be upper triangular except for the diagonal blocks
+*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
+*  possible.  The diagonal scaling matrices DL and DR are chosen so
+*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
+*  one (except for the elements that start out zero.)
+*
+*  After the eigenvalues and eigenvectors of the balanced matrices
+*  have been computed, DGGBAK transforms the eigenvectors back to what
+*  they would have been (in perfect arithmetic) if they had not been
+*  balanced.
+*
+*  Contents of A and B on Exit
+*  -------- -- - --- - -- ----
+*
+*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
+*  both), then on exit the arrays A and B will contain the real Schur
+*  form[*] of the "balanced" versions of A and B.  If no eigenvectors
+*  are computed, then only the diagonal blocks will be correct.
+*
+*  [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations",
+*      by Golub & van Loan, pub. by Johns Hopkins U. Press.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILIMIT, ILV, ILVL, ILVR, LQUERY
+      CHARACTER          CHTEMP
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
+     $                   LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+      DOUBLE PRECISION   ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
+     $                   BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
+     $                   SALFAI, SALFAR, SBETA, SCALE, TEMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, 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, INT, MAX
+*     ..
+*     .. 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
+*
+      LWKMIN = MAX( 8*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( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -12
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LWORK.LT.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 + MAX( 6*N, N*( NB+1 ) )
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEGV ', -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' )
+      SAFMIN = SAFMIN + SAFMIN
+      SAFMAX = ONE / SAFMIN
+      ONEPLS = ONE + ( 4*EPS )
+*
+*     Scale A
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ANRM1 = ANRM
+      ANRM2 = ONE
+      IF( ANRM.LT.ONE ) THEN
+         IF( SAFMAX*ANRM.LT.ONE ) THEN
+            ANRM1 = SAFMIN
+            ANRM2 = SAFMAX*ANRM
+         END IF
+      END IF
+*
+      IF( ANRM.GT.ZERO ) THEN
+         CALL DLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Scale B
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      BNRM1 = BNRM
+      BNRM2 = ONE
+      IF( BNRM.LT.ONE ) THEN
+         IF( SAFMAX*BNRM.LT.ONE ) THEN
+            BNRM1 = SAFMIN
+            BNRM2 = SAFMAX*BNRM
+         END IF
+      END IF
+*
+      IF( BNRM.GT.ZERO ) THEN
+         CALL DLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Permute the matrix to make it more nearly triangular
+*     Workspace layout:  (8*N words -- "work" requires 6*N words)
+*        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 120
+      END IF
+*
+*     Reduce B to triangular form, and initialize VL and/or VR
+*     Workspace layout:  ("work..." must have at least N words)
+*        left_permutation, right_permutation, tau, work...
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      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 120
+      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 120
+      END IF
+*
+      IF( ILVL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VL( ILO+1, ILO ), LDVL )
+         CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                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 120
+         END IF
+      END IF
+*
+      IF( ILVR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      IF( ILV ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IINFO )
+      ELSE
+         CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
+      END IF
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 5
+         GO TO 120
+      END IF
+*
+*     Perform QZ algorithm
+*     Workspace layout:  ("work..." must have at least 1 word)
+*        left_permutation, right_permutation, work...
+*
+      IWORK = 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( 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 120
+      END IF
+*
+      IF( ILV ) THEN
+*
+*        Compute Eigenvectors  (DTGEVC requires 6*N words of workspace)
+*
+         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( IWORK ), IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 120
+         END IF
+*
+*        Undo balancing on VL and VR, rescale
+*
+         IF( ILVL ) THEN
+            CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                   WORK( IRIGHT ), N, VL, LDVL, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 8
+               GO TO 120
+            END IF
+            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.SAFMIN )
+     $            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, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 9
+               GO TO 120
+            END IF
+            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.SAFMIN )
+     $            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 in alpha, beta
+*
+*     Note: this does not give the alpha and beta for the unscaled
+*     problem.
+*
+*     Un-scaling is limited to avoid underflow in alpha and beta
+*     if they are significant.
+*
+      DO 110 JC = 1, N
+         ABSAR = ABS( ALPHAR( JC ) )
+         ABSAI = ABS( ALPHAI( JC ) )
+         ABSB = ABS( BETA( JC ) )
+         SALFAR = ANRM*ALPHAR( JC )
+         SALFAI = ANRM*ALPHAI( JC )
+         SBETA = BNRM*BETA( JC )
+         ILIMIT = .FALSE.
+         SCALE = ONE
+*
+*        Check for significant underflow in ALPHAI
+*
+         IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
+     $              MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
+*
+         ELSE IF( SALFAI.EQ.ZERO ) THEN
+*
+*           If insignificant underflow in ALPHAI, then make the
+*           conjugate eigenvalue real.
+*
+            IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
+               ALPHAI( JC-1 ) = ZERO
+            ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
+               ALPHAI( JC+1 ) = ZERO
+            END IF
+         END IF
+*
+*        Check for significant underflow in ALPHAR
+*
+         IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
+     $       MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
+     $              MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
+         END IF
+*
+*        Check for significant underflow in BETA
+*
+         IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
+     $              MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
+         END IF
+*
+*        Check for possible overflow when limiting scaling
+*
+         IF( ILIMIT ) THEN
+            TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
+     $             ABS( SBETA ) )
+            IF( TEMP.GT.ONE )
+     $         SCALE = SCALE / TEMP
+            IF( SCALE.LT.ONE )
+     $         ILIMIT = .FALSE.
+         END IF
+*
+*        Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
+*
+         IF( ILIMIT ) THEN
+            SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
+            SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
+            SBETA = ( SCALE*BETA( JC ) )*BNRM
+         END IF
+         ALPHAR( JC ) = SALFAR
+         ALPHAI( JC ) = SALFAI
+         BETA( JC ) = SBETA
+  110 CONTINUE
+*
+  120 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DGEGV
+*
+      END
diff --git a/SRC/dgehd2.f b/SRC/dgehd2.f
new file mode 100644
index 00000000..28d1cc8d
--- /dev/null
+++ b/SRC/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/dgehrd.f b/SRC/dgehrd.f
new file mode 100644
index 00000000..339ee400
--- /dev/null
+++ b/SRC/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/dgelq2.f b/SRC/dgelq2.f
new file mode 100644
index 00000000..386ea1b4
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( 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/dgelqf.f b/SRC/dgelqf.f
new file mode 100644
index 00000000..063a38ba
--- /dev/null
+++ b/SRC/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/dgels.f b/SRC/dgels.f
new file mode 100644
index 00000000..4fa1e229
--- /dev/null
+++ b/SRC/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/dgelsd.f b/SRC/dgelsd.f
new file mode 100644
index 00000000..7b9a0a69
--- /dev/null
+++ b/SRC/dgelsd.f
@@ -0,0 +1,532 @@
+      SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+     $                   WORK, LWORK, IWORK, 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            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELSD computes the minimum-norm solution to a real linear least
+*  squares problem:
+*      minimize 2-norm(| b - A*x |)
+*  using the singular value decomposition (SVD) of A. A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The problem is solved in three steps:
+*  (1) Reduce the coefficient matrix A to bidiagonal form with
+*      Householder transformations, reducing the original problem
+*      into a "bidiagonal least squares problem" (BLS)
+*  (2) Solve the BLS using a divide and conquer approach.
+*  (3) Apply back all the Householder tranformations to solve
+*      the original least squares problem.
+*
+*  The effective rank of A is determined by treating as zero those
+*  singular values which are less than RCOND times the largest singular
+*  value.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of 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)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been destroyed.
+*
+*  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 must be at least 1.
+*          The exact minimum amount of workspace needed depends on M,
+*          N and NRHS. As long as LWORK is at least
+*              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
+*          if M is greater than or equal to N or
+*              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
+*          if M is less than N, the code will execute correctly.
+*          SMLSIZ is returned by ILAENV and is equal to the maximum
+*          size of the subproblems at the bottom of the computation
+*          tree (usually about 25), and
+*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
+*          where MINMN = MIN( M,N ).
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
+     $                   LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM,
+     $                   MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD,
+     $                   DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, INT, LOG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      MAXMN = MAX( M, N )
+      MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
+         INFO = -7
+      END IF
+*
+      SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 )
+*
+*     Compute workspace.
+*     (Note: Comments in the code beginning "Workspace:" describe the
+*     minimal amount of workspace needed at that point in the code,
+*     as well as the preferred amount for good performance.
+*     NB refers to the optimal block size for the immediately
+*     following subroutine, as returned by ILAENV.)
+*
+      MINWRK = 1
+      MINMN = MAX( 1, MINMN )
+      NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) /
+     $       LOG( TWO ) ) + 1, 0 )
+*
+      IF( INFO.EQ.0 ) THEN
+         MAXWRK = 0
+         MM = M
+         IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns.
+*
+            MM = N
+            MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N,
+     $               -1, -1 ) )
+            MAXWRK = MAX( MAXWRK, N+NRHS*
+     $               ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
+         END IF
+         IF( M.GE.N ) THEN
+*
+*           Path 1 - overdetermined or exactly determined.
+*
+            MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
+     $               ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
+            MAXWRK = MAX( MAXWRK, 3*N+NRHS*
+     $               ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
+            MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+     $               ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) )
+            WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2
+            MAXWRK = MAX( MAXWRK, 3*N+WLALSD )
+            MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD )
+         END IF
+         IF( N.GT.M ) THEN
+            WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2
+            IF( N.GE.MNTHR ) THEN
+*
+*              Path 2a - underdetermined, with many more columns
+*              than rows.
+*
+               MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+               MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
+     $                  ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
+     $                  ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
+               MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
+     $                  ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) )
+               IF( NRHS.GT.1 ) THEN
+                  MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
+               ELSE
+                  MAXWRK = MAX( MAXWRK, M*M+2*M )
+               END IF
+               MAXWRK = MAX( MAXWRK, M+NRHS*
+     $                  ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
+               MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD )
+!     XXX: Ensure the Path 2a case below is triggered.  The workspace
+!     calculation should use queries for all routines eventually.
+               MAXWRK = MAX( MAXWRK,
+     $              4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) )
+            ELSE
+*
+*              Path 2 - remaining underdetermined cases.
+*
+               MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MAXWRK = MAX( MAXWRK, 3*M+NRHS*
+     $                  ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*M+M*
+     $                  ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*M+WLALSD )
+            END IF
+            MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD )
+         END IF
+         MINWRK = MIN( MINWRK, MAXWRK )
+         WORK( 1 ) = MAXWRK
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELSD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         GO TO 10
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RANK = 0
+         RETURN
+      END IF
+*
+*     Get machine parameters.
+*
+      EPS = DLAMCH( 'P' )
+      SFMIN = DLAMCH( 'S' )
+      SMLNUM = SFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A if max entry outside range [SMLNUM,BIGNUM].
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM.
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM.
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+         RANK = 0
+         GO TO 10
+      END IF
+*
+*     Scale B if max entry outside range [SMLNUM,BIGNUM].
+*
+      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM.
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM.
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     If M < N make sure certain entries of B are zero.
+*
+      IF( M.LT.N )
+     $   CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+*
+*     Overdetermined case.
+*
+      IF( M.GE.N ) THEN
+*
+*        Path 1 - overdetermined or exactly determined.
+*
+         MM = M
+         IF( M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns.
+*
+            MM = N
+            ITAU = 1
+            NWORK = ITAU + N
+*
+*           Compute A=Q*R.
+*           (Workspace: need 2*N, prefer N+N*NB)
+*
+            CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                   LWORK-NWORK+1, INFO )
+*
+*           Multiply B by transpose(Q).
+*           (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+            CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*           Zero out below R.
+*
+            IF( N.GT.1 ) THEN
+               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+            END IF
+         END IF
+*
+         IE = 1
+         ITAUQ = IE + N
+         ITAUP = ITAUQ + N
+         NWORK = ITAUP + N
+*
+*        Bidiagonalize R in A.
+*        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+         CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R.
+*        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+         CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of R.
+*
+         CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+     $         MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN
+*
+*        Path 2a - underdetermined, with many more columns than rows
+*        and sufficient workspace for an efficient algorithm.
+*
+         LDWORK = M
+         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+     $       M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA
+         ITAU = 1
+         NWORK = M + 1
+*
+*        Compute A=L*Q.
+*        (Workspace: need 2*M, prefer M+M*NB)
+*
+         CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+         IL = NWORK
+*
+*        Copy L to WORK(IL), zeroing out above its diagonal.
+*
+         CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         IE = IL + LDWORK*M
+         ITAUQ = IE + M
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+*
+*        Bidiagonalize L in WORK(IL).
+*        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+         CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L.
+*        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUQ ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of L.
+*
+         CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUP ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Zero out below first M rows of B.
+*
+         CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+         NWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B.
+*        (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+         CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases.
+*
+         IE = 1
+         ITAUQ = IE + M
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+*
+*        Bidiagonalize A.
+*        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+         CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors.
+*        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of A.
+*
+         CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      END IF
+*
+*     Undo scaling.
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   10 CONTINUE
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of DGELSD
+*
+      END
diff --git a/SRC/dgelss.f b/SRC/dgelss.f
new file mode 100644
index 00000000..f024e138
--- /dev/null
+++ b/SRC/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/dgelsx.f b/SRC/dgelsx.f
new file mode 100644
index 00000000..a597cd47
--- /dev/null
+++ b/SRC/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/dgelsy.f b/SRC/dgelsy.f
new file mode 100644
index 00000000..4334650f
--- /dev/null
+++ b/SRC/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/dgeql2.f b/SRC/dgeql2.f
new file mode 100644
index 00000000..7b2d46b5
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( 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/dgeqlf.f b/SRC/dgeqlf.f
new file mode 100644
index 00000000..ec293574
--- /dev/null
+++ b/SRC/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/dgeqp3.f b/SRC/dgeqp3.f
new file mode 100644
index 00000000..d6bc537d
--- /dev/null
+++ b/SRC/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/dgeqpf.f b/SRC/dgeqpf.f
new file mode 100644
index 00000000..217499c3
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
+            ELSE
+               CALL DLARFP( 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/dgeqr2.f b/SRC/dgeqr2.f
new file mode 100644
index 00000000..f3e012de
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( 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/dgeqrf.f b/SRC/dgeqrf.f
new file mode 100644
index 00000000..1e940597
--- /dev/null
+++ b/SRC/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/dgerfs.f b/SRC/dgerfs.f
new file mode 100644
index 00000000..bada6e56
--- /dev/null
+++ b/SRC/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/dgerq2.f b/SRC/dgerq2.f
new file mode 100644
index 00000000..045eab90
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( 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/dgerqf.f b/SRC/dgerqf.f
new file mode 100644
index 00000000..3dc22652
--- /dev/null
+++ b/SRC/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/dgesc2.f b/SRC/dgesc2.f
new file mode 100644
index 00000000..1b0331f5
--- /dev/null
+++ b/SRC/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/dgesdd.f b/SRC/dgesdd.f
new file mode 100644
index 00000000..7a202f1c
--- /dev/null
+++ b/SRC/dgesdd.f
@@ -0,0 +1,1339 @@
+      SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
+     $                   LWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ
+      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), S( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGESDD computes the singular value decomposition (SVD) of a real
+*  M-by-N matrix A, optionally computing the left and right singular
+*  vectors.  If singular vectors are desired, it uses a
+*  divide-and-conquer algorithm.
+*
+*  The SVD is written
+*
+*       A = U * SIGMA * transpose(V)
+*
+*  where SIGMA is an M-by-N matrix which is zero except for its
+*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
+*  are the singular values of A; they are real and non-negative, and
+*  are returned in descending order.  The first min(m,n) columns of
+*  U and V are the left and right singular vectors of A.
+*
+*  Note that the routine returns VT = V**T, not V.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix U:
+*          = 'A':  all M columns of U and all N rows of V**T are
+*                  returned in the arrays U and VT;
+*          = 'S':  the first min(M,N) columns of U and the first
+*                  min(M,N) rows of V**T are returned in the arrays U
+*                  and VT;
+*          = 'O':  If M >= N, the first N columns of U are overwritten
+*                  on the array A and all rows of V**T are returned in
+*                  the array VT;
+*                  otherwise, all columns of U are returned in the
+*                  array U and the first M rows of V**T are overwritten
+*                  in the array A;
+*          = 'N':  no columns of U or rows of V**T are computed.
+*
+*  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 JOBZ = 'O',  A is overwritten with the first N columns
+*                          of U (the left singular vectors, stored
+*                          columnwise) if M >= N;
+*                          A is overwritten with the first M rows
+*                          of V**T (the right singular vectors, stored
+*                          rowwise) otherwise.
+*          if JOBZ .ne. 'O', the contents of A are destroyed.
+*
+*  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)
+*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
+*          UCOL = min(M,N) if JOBZ = 'S'.
+*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
+*          orthogonal matrix U;
+*          if JOBZ = 'S', U contains the first min(M,N) columns of U
+*          (the left singular vectors, stored columnwise);
+*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1; if
+*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
+*
+*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
+*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
+*          N-by-N orthogonal matrix V**T;
+*          if JOBZ = 'S', VT contains the first min(M,N) rows of
+*          V**T (the right singular vectors, stored rowwise);
+*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1; if
+*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
+*          if JOBZ = 'S', LDVT >= min(M,N).
+*
+*  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 JOBZ = 'N',
+*            LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
+*          If JOBZ = 'O',
+*            LWORK >= 3*min(M,N)*min(M,N) + 
+*                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
+*          If JOBZ = 'S' or 'A'
+*            LWORK >= 3*min(M,N)*min(M,N) +
+*                     max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
+*          For good performance, LWORK should generally be larger.
+*          If LWORK = -1 but other input arguments are legal, WORK(1)
+*          returns the optimal LWORK.
+*
+*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  DBDSDC did not converge, updating process failed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
+      INTEGER            BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
+     $                   IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
+     $                   LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
+     $                   MNTHR, NWORK, WRKBL
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
+     $                   DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           DLAMCH, DLANGE, ILAENV, LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      WNTQA = LSAME( JOBZ, 'A' )
+      WNTQS = LSAME( JOBZ, 'S' )
+      WNTQAS = WNTQA .OR. WNTQS
+      WNTQO = LSAME( JOBZ, 'O' )
+      WNTQN = LSAME( JOBZ, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
+     $         ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
+         INFO = -8
+      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
+     $         ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
+     $         ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
+         INFO = -10
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace 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 DBDSDC
+*
+            MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
+            IF( WNTQN ) THEN
+               BDSPAC = 7*N
+            ELSE
+               BDSPAC = 3*N*N + 4*N
+            END IF
+            IF( M.GE.MNTHR ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1 (M much larger than N, JOBZ='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
+     $                    -1 )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+N )
+                  MINWRK = BDSPAC + N
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2 (M much larger than N, JOBZ='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, 'DORMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + 2*N*N
+                  MINWRK = BDSPAC + 2*N*N + 3*N
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3 (M much larger than N, JOBZ='S')
+*
+                  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, 'DORMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + N*N
+                  MINWRK = BDSPAC + N*N + 3*N
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4 (M much larger than N, JOBZ='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, 'DORMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + N*N
+                  MINWRK = BDSPAC + N*N + 3*N
+               END IF
+            ELSE
+*
+*              Path 5 (M at least N, but not much larger)
+*
+               WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
+     $                 -1 )
+               IF( WNTQN ) THEN
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+                  MINWRK = 3*N + MAX( M, BDSPAC )
+               ELSE IF( WNTQO ) THEN
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + M*N
+                  MINWRK = 3*N + MAX( M, N*N+BDSPAC )
+               ELSE IF( WNTQS ) THEN
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+                  MINWRK = 3*N + MAX( M, BDSPAC )
+               ELSE IF( WNTQA ) THEN
+                  WRKBL = MAX( WRKBL, 3*N+M*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
+                  MINWRK = 3*N + MAX( M, BDSPAC )
+               END IF
+            END IF
+         ELSE IF( MINMN.GT.0 ) THEN
+*
+*           Compute space needed for DBDSDC
+*
+            MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
+            IF( WNTQN ) THEN
+               BDSPAC = 7*M
+            ELSE
+               BDSPAC = 3*M*M + 4*M
+            END IF
+            IF( N.GE.MNTHR ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1t (N much larger than M, JOBZ='N')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+     $                    -1 )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+M )
+                  MINWRK = BDSPAC + M
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2t (N much larger than M, JOBZ='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*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + 2*M*M
+                  MINWRK = BDSPAC + 2*M*M + 3*M
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3t (N much larger than M, JOBZ='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*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + M*M
+                  MINWRK = BDSPAC + M*M + 3*M
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4t (N much larger than M, JOBZ='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*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + M*M
+                  MINWRK = BDSPAC + M*M + 3*M
+               END IF
+            ELSE
+*
+*              Path 5t (N greater than M, but not much larger)
+*
+               WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
+     $                 -1 )
+               IF( WNTQN ) THEN
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+                  MINWRK = 3*M + MAX( N, BDSPAC )
+               ELSE IF( WNTQO ) THEN
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + M*N
+                  MINWRK = 3*M + MAX( N, M*M+BDSPAC )
+               ELSE IF( WNTQS ) THEN
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+                  MINWRK = 3*M + MAX( N, BDSPAC )
+               ELSE IF( WNTQA ) THEN
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+                  MINWRK = 3*M + MAX( N, BDSPAC )
+               END IF
+            END IF
+         END IF
+         MAXWRK = MAX( MAXWRK, MINWRK )
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGESDD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        A has at least as many rows as columns. If A has sufficiently
+*        more rows than columns, first reduce using the QR
+*        decomposition (if sufficient workspace available)
+*
+         IF( M.GE.MNTHR ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1 (M much larger than N, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need 2*N, prefer N+N*NB)
+*
+               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+               IE = 1
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+               CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NWORK = IE + N
+*
+*              Perform bidiagonal SVD, computing singular values only
+*              (Workspace: need N+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2 (M much larger than N, JOBZ = 'O')
+*              N left singular vectors to be overwritten on A and
+*              N right singular vectors to be computed in VT
+*
+               IR = 1
+*
+*              WORK(IR) is LDWRKR by N
+*
+               IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
+                  LDWRKR = LDA
+               ELSE
+                  LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
+               END IF
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy R to WORK(IR), zeroing out below it
+*
+               CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+     $                      LDWRKR )
+*
+*              Generate Q in A
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in VT, copying result to 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( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              WORK(IU) is N by N
+*
+               IU = NWORK
+               NWORK = IU + N*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in WORK(IU) and computing right
+*              singular vectors of bidiagonal matrix in VT
+*              (Workspace: need N+N*N+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+     $                      VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite WORK(IU) by left singular vectors of R
+*              and VT by right singular vectors of R
+*              (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IU), storing result in WORK(IR) and copying to A
+*              (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+               DO 10 I = 1, M, LDWRKR
+                  CHUNK = MIN( M-I+1, LDWRKR )
+                  CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                        LDA, WORK( IU ), N, ZERO, WORK( IR ),
+     $                        LDWRKR )
+                  CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+     $                         A( I, 1 ), LDA )
+   10          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Path 3 (M much larger than N, JOBZ='S')
+*              N left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IR = 1
+*
+*              WORK(IR) is N by N
+*
+               LDWRKR = N
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy R to WORK(IR), zeroing out below it
+*
+               CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+     $                      LDWRKR )
+*
+*              Generate Q in A
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in WORK(IR)
+*              (Workspace: need N*N+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( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagoal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need N+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of R and VT
+*              by right singular vectors of R
+*              (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IR), storing result in U
+*              (Workspace: need N*N)
+*
+               CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
+               CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
+     $                     LDWRKR, ZERO, U, LDU )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 4 (M much larger than N, JOBZ='A')
+*              M left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IU = 1
+*
+*              WORK(IU) is N by N
+*
+               LDWRKU = N
+               ITAU = IU + LDWRKU*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R, copying result to U
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*              Generate Q in U
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+               CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce R in A, zeroing out other entries
+*
+               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+               IE = ITAU
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+               CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in WORK(IU) and computing right
+*              singular vectors of bidiagonal matrix in VT
+*              (Workspace: need N+N*N+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+     $                      VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite WORK(IU) by left singular vectors of R and VT
+*              by right singular vectors of R
+*              (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
+     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in U by left singular vectors of R in
+*              WORK(IU), storing result in A
+*              (Workspace: need N*N)
+*
+               CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
+     $                     LDWRKU, ZERO, A, LDA )
+*
+*              Copy left singular vectors of A from A to U
+*
+               CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+            END IF
+*
+         ELSE
+*
+*           M .LT. MNTHR
+*
+*           Path 5 (M at least N, but not much larger)
+*           Reduce to bidiagonal form without QR decomposition
+*
+            IE = 1
+            ITAUQ = IE + N
+            ITAUP = ITAUQ + N
+            NWORK = ITAUP + N
+*
+*           Bidiagonalize A
+*           (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Perform bidiagonal SVD, only computing singular values
+*              (Workspace: need N+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IU = NWORK
+               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+*                 WORK( IU ) is M by N
+*
+                  LDWRKU = M
+                  NWORK = IU + LDWRKU*N
+                  CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
+     $                         LDWRKU )
+               ELSE
+*
+*                 WORK( IU ) is N by N
+*
+                  LDWRKU = N
+                  NWORK = IU + LDWRKU*N
+*
+*                 WORK(IR) is LDWRKR by N
+*
+                  IR = NWORK
+                  LDWRKR = ( LWORK-N*N-3*N ) / N
+               END IF
+               NWORK = IU + LDWRKU*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in WORK(IU) and computing right
+*              singular vectors of bidiagonal matrix in VT
+*              (Workspace: need N+N*N+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
+     $                      LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
+     $                      IWORK, INFO )
+*
+*              Overwrite VT by right singular vectors of A
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+*                 Overwrite WORK(IU) by left singular vectors of A
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                         WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Copy left singular vectors of A from WORK(IU) to A
+*
+                  CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
+               ELSE
+*
+*                 Generate Q in A
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by left singular vectors of
+*                 bidiagonal matrix in WORK(IU), storing result in
+*                 WORK(IR) and copying to A
+*                 (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+                  DO 20 I = 1, M, LDWRKR
+                     CHUNK = MIN( M-I+1, LDWRKR )
+                     CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                           LDA, WORK( IU ), LDWRKU, ZERO,
+     $                           WORK( IR ), LDWRKR )
+                     CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+     $                            A( I, 1 ), LDA )
+   20             CONTINUE
+               END IF
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need N+BDSPAC)
+*
+               CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU )
+               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE IF( WNTQA ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need N+BDSPAC)
+*
+               CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU )
+               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Set the right corner of U to identity matrix
+*
+               IF( M.GT.N ) THEN
+                  CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
+     $                         LDU )
+               END IF
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      ELSE
+*
+*        A has more columns than rows. If A has sufficiently more
+*        columns than rows, first reduce using the LQ decomposition (if
+*        sufficient workspace available)
+*
+         IF( N.GE.MNTHR ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1t (N much larger than M, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need 2*M, prefer M+M*NB)
+*
+               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+               IE = 1
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NWORK = IE + M
+*
+*              Perform bidiagonal SVD, computing singular values only
+*              (Workspace: need M+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2t (N much larger than M, JOBZ='O')
+*              M right singular vectors to be overwritten on A and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+*
+*              IVT is M by M
+*
+               IL = IVT + M*M
+               IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
+*
+*                 WORK(IL) is M by N
+*
+                  LDWRKL = M
+                  CHUNK = N
+               ELSE
+                  LDWRKL = M
+                  CHUNK = ( LWORK-M*M ) / M
+               END IF
+               ITAU = IL + LDWRKL*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing about above it
+*
+               CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              Generate Q in A
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IL)
+*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+               CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U, and computing right singular
+*              vectors of bidiagonal matrix in WORK(IVT)
+*              (Workspace: need M+M*M+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+     $                      WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
+     $                      IWORK, INFO )
+*
+*              Overwrite U by left singular vectors of L and WORK(IVT)
+*              by right singular vectors of L
+*              (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), WORK( IVT ), M,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IVT) by Q
+*              in A, storing result in WORK(IL) and copying to A
+*              (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+               DO 30 I = 1, N, CHUNK
+                  BLK = MIN( N-I+1, CHUNK )
+                  CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
+     $                        A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
+                  CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
+     $                         A( 1, I ), LDA )
+   30          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Path 3t (N much larger than M, JOBZ='S')
+*              M right singular vectors to be computed in VT and
+*              M left singular vectors to be computed in U
+*
+               IL = 1
+*
+*              WORK(IL) is M by M
+*
+               LDWRKL = M
+               ITAU = IL + LDWRKL*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing out above it
+*
+               CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              Generate Q in A
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IU), copying result to U
+*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+               CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need M+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of L and VT
+*              by right singular vectors of L
+*              (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IL) by
+*              Q in A, storing result in VT
+*              (Workspace: need M*M)
+*
+               CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
+               CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
+     $                     A, LDA, ZERO, VT, LDVT )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 4t (N much larger than M, JOBZ='A')
+*              N right singular vectors to be computed in VT and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+*
+*              WORK(IVT) is M by M
+*
+               LDWKVT = M
+               ITAU = IVT + LDWKVT*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q, copying result to VT
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*              Generate Q in VT
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce L in A, zeroing out other entries
+*
+               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+               IE = ITAU
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in WORK(IVT)
+*              (Workspace: need M+M*M+BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+     $                      WORK( IVT ), LDWKVT, DUM, IDUM,
+     $                      WORK( NWORK ), IWORK, INFO )
+*
+*              Overwrite U by left singular vectors of L and WORK(IVT)
+*              by right singular vectors of L
+*              (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
+     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IVT) by
+*              Q in VT, storing result in A
+*              (Workspace: need M*M)
+*
+               CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
+     $                     VT, LDVT, ZERO, A, LDA )
+*
+*              Copy right singular vectors of A from A to VT
+*
+               CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+            END IF
+*
+         ELSE
+*
+*           N .LT. MNTHR
+*
+*           Path 5t (N greater than M, but not much larger)
+*           Reduce to bidiagonal form without LQ decomposition
+*
+            IE = 1
+            ITAUQ = IE + M
+            ITAUP = ITAUQ + M
+            NWORK = ITAUP + M
+*
+*           Bidiagonalize A
+*           (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Perform bidiagonal SVD, only computing singular values
+*              (Workspace: need M+BDSPAC)
+*
+               CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               LDWKVT = M
+               IVT = NWORK
+               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+*                 WORK( IVT ) is M by N
+*
+                  CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
+     $                         LDWKVT )
+                  NWORK = IVT + LDWKVT*N
+               ELSE
+*
+*                 WORK( IVT ) is M by M
+*
+                  NWORK = IVT + LDWKVT*M
+                  IL = NWORK
+*
+*                 WORK(IL) is M by CHUNK
+*
+                  CHUNK = ( LWORK-M*M-3*M ) / M
+               END IF
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in WORK(IVT)
+*              (Workspace: need M*M+BDSPAC)
+*
+               CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
+     $                      WORK( IVT ), LDWKVT, DUM, IDUM,
+     $                      WORK( NWORK ), IWORK, INFO )
+*
+*              Overwrite U by left singular vectors of A
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+*                 Overwrite WORK(IVT) by left singular vectors of A
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+     $                         WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Copy right singular vectors of A from WORK(IVT) to A
+*
+                  CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
+               ELSE
+*
+*                 Generate P**T in A
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by right singular vectors of
+*                 bidiagonal matrix in WORK(IVT), storing result in
+*                 WORK(IL) and copying to A
+*                 (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+                  DO 40 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
+     $                           LDWKVT, A( 1, I ), LDA, ZERO,
+     $                           WORK( IL ), M )
+                     CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
+     $                            LDA )
+   40             CONTINUE
+               END IF
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need M+BDSPAC)
+*
+               CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
+               CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need 3*M, prefer 2*M+M*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE IF( WNTQA ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need M+BDSPAC)
+*
+               CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
+               CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Set the right corner of VT to identity matrix
+*
+               IF( N.GT.M ) THEN
+                  CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
+     $                         LDVT )
+               END IF
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need 2*M+N, prefer 2*M+N*NB)
+*
+               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ISCL.EQ.1 ) THEN
+         IF( ANRM.GT.BIGNUM )
+     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+      END IF
+*
+*     Return optimal workspace in WORK(1)
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of DGESDD
+*
+      END
diff --git a/SRC/dgesv.f b/SRC/dgesv.f
new file mode 100644
index 00000000..220ef56f
--- /dev/null
+++ b/SRC/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/dgesvd.f b/SRC/dgesvd.f
new file mode 100644
index 00000000..0b62ca10
--- /dev/null
+++ b/SRC/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/dgesvx.f b/SRC/dgesvx.f
new file mode 100644
index 00000000..0645a20c
--- /dev/null
+++ b/SRC/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/dgetc2.f b/SRC/dgetc2.f
new file mode 100644
index 00000000..5842b213
--- /dev/null
+++ b/SRC/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/dgetf2.f b/SRC/dgetf2.f
new file mode 100644
index 00000000..573b1408
--- /dev/null
+++ b/SRC/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/dgetrf.f b/SRC/dgetrf.f
new file mode 100644
index 00000000..c5b9df33
--- /dev/null
+++ b/SRC/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/dgetri.f b/SRC/dgetri.f
new file mode 100644
index 00000000..9f1c1182
--- /dev/null
+++ b/SRC/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/dgetrs.f b/SRC/dgetrs.f
new file mode 100644
index 00000000..b7d17b0a
--- /dev/null
+++ b/SRC/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/dggbak.f b/SRC/dggbak.f
new file mode 100644
index 00000000..8ed9fbd4
--- /dev/null
+++ b/SRC/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/dggbal.f b/SRC/dggbal.f
new file mode 100644
index 00000000..2034880a
--- /dev/null
+++ b/SRC/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/dgges.f b/SRC/dgges.f
new file mode 100644
index 00000000..d5b1455d
--- /dev/null
+++ b/SRC/dgges.f
@@ -0,0 +1,560 @@
+      SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
+     $                  SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
+     $                  LDVSR, WORK, LWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.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   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+     $                   VSR( LDVSR, * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  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 SELCTG);
+*
+*  SELCTG  (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
+*          SELCTG must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'N', SELCTG is not referenced.
+*          If SORT = 'S', SELCTG is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+*          one of a complex conjugate pair of eigenvalues is selected,
+*          then both complex eigenvalues are selected.
+*
+*          Note that in the ill-conditioned case, a selected complex
+*          eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
+*          BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
+*          in this case.
+*
+*  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 SELCTG is true.  (Complex conjugate pairs for which
+*          SELCTG 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 (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N = 0, LWORK >= 1, else LWORK >= 8*N+16.
+*          For good performance , LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  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 SELCTG=.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.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.GT.0 )THEN
+            MINWRK = MAX( 8*N, 6*N + 16 )
+            MAXWRK = MINWRK - N +
+     $               N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
+            MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $                    N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) )
+            IF( ILVSL ) THEN
+               MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $                       N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
+            END IF
+         ELSE
+            MINWRK = 1
+            MAXWRK = 1
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+     $      INFO = -19
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGES ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      SMLNUM = SQRT( SAFMIN ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+      IF( ILASCL )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+      IF( ILBSCL )
+     $   CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (Workspace: need 6*N + 2*N space for storing balancing factors)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWRK = IRIGHT + N
+      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+     $             WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Workspace: need N, prefer N*NB)
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = IWRK
+      IWRK = ITAU + IROWS
+      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to matrix A
+*     (Workspace: need N, prefer N*NB)
+*
+      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VSL
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVSL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+     $             LDVSL, VSR, LDVSR, IERR )
+*
+*     Perform QZ algorithm, computing Schur vectors if desired
+*     (Workspace: need N)
+*
+      IWRK = ITAU
+      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 50
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA if desired
+*     (Workspace: need 4*N+16 )
+*
+      SDIM = 0
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before SELCTGing
+*
+         IF( ILASCL ) THEN
+            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                   IERR )
+            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+     $                   IERR )
+         END IF
+         IF( ILBSCL )
+     $      CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+   10    CONTINUE
+*
+         CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR,
+     $                ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL,
+     $                PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+     $                IERR )
+         IF( IERR.EQ.1 )
+     $      INFO = N + 3
+*
+      END IF
+*
+*     Apply back-permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+      IF( ILVSR )
+     $   CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+*     Check if unscaling would cause over/underflow, if so, rescale
+*     (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+*     B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+      IF( ILASCL ) THEN
+         DO 20 I = 1, N
+            IF( ALPHAI( I ).NE.ZERO ) THEN
+               IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
+     $             ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
+                  WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
+     $                  ( ANRMTO / ANRM ) .OR.
+     $                  ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
+     $                   THEN
+                  WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               END IF
+            END IF
+   20    CONTINUE
+      END IF
+*
+      IF( ILBSCL ) THEN
+         DO 30 I = 1, N
+            IF( ALPHAI( I ).NE.ZERO ) THEN
+               IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
+     $             ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
+                  WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               END IF
+            END IF
+   30    CONTINUE
+      END IF
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+      IF( WANTST ) THEN
+*
+*        Check if reordering is correct
+*
+         LASTSL = .TRUE.
+         LST2SL = .TRUE.
+         SDIM = 0
+         IP = 0
+         DO 40 I = 1, N
+            CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+            IF( ALPHAI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   40    CONTINUE
+*
+      END IF
+*
+   50 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of DGGES
+*
+      END
diff --git a/SRC/dggesx.f b/SRC/dggesx.f
new file mode 100644
index 00000000..f3548443
--- /dev/null
+++ b/SRC/dggesx.f
@@ -0,0 +1,676 @@
+      SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
+     $                   B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL,
+     $                   VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK,
+     $                   LIWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVSL, JOBVSR, SENSE, SORT
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
+     $                   SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), RCONDE( 2 ),
+     $                   RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGESX computes for a pair of N-by-N real nonsymmetric matrices
+*  (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
+*  optionally, the left and/or right matrices of Schur vectors (VSL and
+*  VSR).  This gives the generalized Schur factorization
+*
+*       (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
+*
+*  Optionally, it also orders the eigenvalues so that a selected cluster
+*  of eigenvalues appears in the leading diagonal blocks of the upper
+*  quasi-triangular matrix S and the upper triangular matrix T; computes
+*  a reciprocal condition number for the average of the selected
+*  eigenvalues (RCONDE); and computes a reciprocal condition number for
+*  the right and left deflating subspaces corresponding to the selected
+*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form
+*  an orthonormal basis for the corresponding left and right eigenspaces
+*  (deflating subspaces).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
+*  usually represented as the pair (alpha,beta), as there is a
+*  reasonable interpretation for beta=0 or for both being zero.
+*
+*  A pair of matrices (S,T) is in generalized real Schur form if T is
+*  upper triangular with non-negative diagonal and S is block upper
+*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
+*  to real generalized eigenvalues, while 2-by-2 blocks of S will be
+*  "standardized" by making the corresponding elements of T have the
+*  form:
+*          [  a  0  ]
+*          [  0  b  ]
+*
+*  and the pair of corresponding 2-by-2 blocks in S and T will have a
+*  complex conjugate pair of generalized eigenvalues.
+*
+*
+*  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 three DOUBLE PRECISION arguments
+*          SELCTG must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'N', SELCTG is not referenced.
+*          If SORT = 'S', SELCTG is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+*          one of a complex conjugate pair of eigenvalues is selected,
+*          then both complex eigenvalues are selected.
+*          Note that a selected complex eigenvalue may no longer satisfy
+*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
+*          since ordering may change the value of complex eigenvalues
+*          (especially if the eigenvalue is ill-conditioned), in this
+*          case INFO is set to N+3.
+*
+*  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 deflating subspaces only;
+*          = 'B' : Computed for both.
+*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
+*
+*  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 SELCTG is true.  (Complex conjugate pairs for which
+*          SELCTG 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.
+*
+*  RCONDE  (output) DOUBLE PRECISION array, dimension ( 2 )
+*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
+*          reciprocal condition numbers for the average of the selected
+*          eigenvalues.
+*          Not referenced if SENSE = 'N' or 'V'.
+*
+*  RCONDV  (output) DOUBLE PRECISION array, dimension ( 2 )
+*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
+*          reciprocal condition numbers for the selected deflating
+*          subspaces.
+*          Not referenced if SENSE = 'N' or 'E'.
+*
+*  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 N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
+*          LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
+*          LWORK >= max( 8*N, 6*N+16 ).
+*          Note that 2*SDIM*(N-SDIM) <= N*N/2.
+*          Note also that an error is only returned if
+*          LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
+*          this may not be large enough.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the bound on the optimal size of the WORK
+*          array and the minimum size of the IWORK array, returns these
+*          values as the first entries of the WORK and IWORK arrays, and
+*          no error message related to LWORK or LIWORK is issued by
+*          XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
+*          LIWORK >= N+6.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the bound on the optimal size of the
+*          WORK array and the minimum size of the IWORK array, returns
+*          these values as the first entries of the WORK and IWORK
+*          arrays, and no error message related to LWORK or LIWORK is
+*          issued by XERBLA.
+*
+*  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 SELCTG=.TRUE.  This could also
+*                      be caused due to scaling.
+*                =N+3: reordering failed in DTGSEN.
+*
+*  Further details
+*  ===============
+*
+*  An approximate (asymptotic) bound on the average absolute error of
+*  the selected eigenvalues is
+*
+*       EPS * norm((A, B)) / RCONDE( 1 ).
+*
+*  An approximate (asymptotic) bound on the maximum angular error in
+*  the computed deflating subspaces is
+*
+*       EPS * norm((A, B)) / RCONDV( 2 ).
+*
+*  See LAPACK User's Guide, section 4.11 for more information.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+     $                   LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST,
+     $                   WANTSV
+      INTEGER            I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
+     $                   ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK,
+     $                   LIWMIN, LWRK, MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
+     $                   PR, SAFMAX, SAFMIN, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+     $                   DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVSL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVSL = .FALSE.
+      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVSL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVSL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVSR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVSR = .FALSE.
+      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVSR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVSR = .FALSE.
+      END IF
+*
+      WANTST = LSAME( SORT, 'S' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+      IF( WANTSN ) THEN
+         IJOB = 0
+      ELSE IF( WANTSE ) THEN
+         IJOB = 1
+      ELSE IF( WANTSV ) THEN
+         IJOB = 2
+      ELSE IF( WANTSB ) THEN
+         IJOB = 4
+      END IF
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+     $         ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -16
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -18
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.GT.0) THEN
+            MINWRK = MAX( 8*N, 6*N + 16 )
+            MAXWRK = MINWRK - N +
+     $               N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
+            MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $               N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) )
+            IF( ILVSL ) THEN
+               MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $                  N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
+            END IF
+            LWRK = MAXWRK
+            IF( IJOB.GE.1 )
+     $         LWRK = MAX( LWRK, N*N/2 )
+         ELSE
+            MINWRK = 1
+            MAXWRK = 1
+            LWRK   = 1
+         END IF
+         WORK( 1 ) = LWRK
+         IF( WANTSN .OR. N.EQ.0 ) THEN
+            LIWMIN = 1
+         ELSE
+            LIWMIN = N + 6
+         END IF
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -22
+         ELSE IF( LIWORK.LT.LIWMIN  .AND. .NOT.LQUERY ) THEN
+            INFO = -24
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGESX', -INFO )
+         RETURN
+      ELSE IF (LQUERY) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      SMLNUM = SQRT( SAFMIN ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+      IF( ILASCL )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+      IF( ILBSCL )
+     $   CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (Workspace: need 6*N + 2*N for permutation parameters)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWRK = IRIGHT + N
+      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+     $             WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Workspace: need N, prefer N*NB)
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = IWRK
+      IWRK = ITAU + IROWS
+      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to matrix A
+*     (Workspace: need N, prefer N*NB)
+*
+      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VSL
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVSL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+     $             LDVSL, VSR, LDVSR, IERR )
+*
+      SDIM = 0
+*
+*     Perform QZ algorithm, computing Schur vectors if desired
+*     (Workspace: need N)
+*
+      IWRK = ITAU
+      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 60
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA and compute the reciprocal of
+*     condition number(s)
+*     (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
+*                 otherwise, need 8*(N+1) )
+*
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before SELCTGing
+*
+         IF( ILASCL ) THEN
+            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                   IERR )
+            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+     $                   IERR )
+         END IF
+         IF( ILBSCL )
+     $      CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues, transform Generalized Schur vectors, and
+*        compute reciprocal condition numbers
+*
+         CALL DTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
+     $                ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+     $                SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1,
+     $                IWORK, LIWORK, IERR )
+*
+         IF( IJOB.GE.1 )
+     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+         IF( IERR.EQ.-22 ) THEN
+*
+*            not enough real workspace
+*
+            INFO = -22
+         ELSE
+            IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
+               RCONDE( 1 ) = PL
+               RCONDE( 2 ) = PR
+            END IF
+            IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+               RCONDV( 1 ) = DIF( 1 )
+               RCONDV( 2 ) = DIF( 2 )
+            END IF
+            IF( IERR.EQ.1 )
+     $         INFO = N + 3
+         END IF
+*
+      END IF
+*
+*     Apply permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+      IF( ILVSR )
+     $   CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+*     Check if unscaling would cause over/underflow, if so, rescale
+*     (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+*     B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+      IF( ILASCL ) THEN
+         DO 20 I = 1, N
+            IF( ALPHAI( I ).NE.ZERO ) THEN
+               IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
+     $             ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
+                  WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
+     $                  ( ANRMTO / ANRM ) .OR.
+     $                  ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
+     $                   THEN
+                  WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               END IF
+            END IF
+   20    CONTINUE
+      END IF
+*
+      IF( ILBSCL ) THEN
+         DO 30 I = 1, N
+            IF( ALPHAI( I ).NE.ZERO ) THEN
+               IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
+     $             ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
+                  WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               END IF
+            END IF
+   30    CONTINUE
+      END IF
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+      IF( WANTST ) THEN
+*
+*        Check if reordering is correct
+*
+         LASTSL = .TRUE.
+         LST2SL = .TRUE.
+         SDIM = 0
+         IP = 0
+         DO 50 I = 1, N
+            CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+            IF( ALPHAI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   50    CONTINUE
+*
+      END IF
+*
+   60 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DGGESX
+*
+      END
diff --git a/SRC/dggev.f b/SRC/dggev.f
new file mode 100644
index 00000000..4a204c33
--- /dev/null
+++ b/SRC/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/dggevx.f b/SRC/dggevx.f
new file mode 100644
index 00000000..0d2cc424
--- /dev/null
+++ b/SRC/dggevx.f
@@ -0,0 +1,718 @@
+      SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
+     $                   ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO,
+     $                   IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE,
+     $                   RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+      DOUBLE PRECISION   ABNRM, BBNRM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), LSCALE( * ),
+     $                   RCONDE( * ), RCONDV( * ), RSCALE( * ),
+     $                   VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+*  the generalized eigenvalues, and optionally, the left and/or right
+*  generalized eigenvectors.
+*
+*  Optionally also, it computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
+*  the eigenvalues (RCONDE), and reciprocal condition numbers for the
+*  right eigenvectors (RCONDV).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+*  singular. It is usually represented as the pair (alpha,beta), as
+*  there is a reasonable interpretation for beta=0, and even for both
+*  being zero.
+*
+*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*
+*                   A * v(j) = lambda(j) * B * v(j) .
+*
+*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*
+*                   u(j)**H * A  = lambda(j) * u(j)**H * B.
+*
+*  where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Specifies the balance option to be performed.
+*          = 'N':  do not diagonally scale or permute;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*          Computed reciprocal condition numbers will be for the
+*          matrices after permuting and/or balancing. Permuting does
+*          not change condition numbers (in exact arithmetic), but
+*          balancing does.
+*
+*  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.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': none are computed;
+*          = 'E': computed for eigenvalues only;
+*          = 'V': computed for eigenvectors only;
+*          = 'B': computed for eigenvalues and eigenvectors.
+*
+*  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. If JOBVL='V' or JOBVR='V'
+*          or both, then A contains the first part of the real Schur
+*          form of the "balanced" versions of the input A and B.
+*
+*  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. If JOBVL='V' or JOBVR='V'
+*          or both, then B contains the second part of the real Schur
+*          form of the "balanced" versions of the input A and B.
+*
+*  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 will be scaled so the largest component have
+*          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 will be scaled so the largest component have
+*          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.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values such that on exit
+*          A(i,j) = 0 and B(i,j) = 0 if i > j and
+*          j = 1,...,ILO-1 or i = IHI+1,...,N.
+*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the left side of A and B.  If PL(j) is the index of the
+*          row interchanged with row j, and DL(j) is the scaling
+*          factor applied to row j, then
+*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1
+*                      = DL(j)  for j = ILO,...,IHI
+*                      = PL(j)  for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the right side of A and B.  If PR(j) is the index of the
+*          column interchanged with column j, and DR(j) is the scaling
+*          factor applied to column j, then
+*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1
+*                      = DR(j)  for j = ILO,...,IHI
+*                      = PR(j)  for j = IHI+1,...,N
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) DOUBLE PRECISION
+*          The one-norm of the balanced matrix A.
+*
+*  BBNRM   (output) DOUBLE PRECISION
+*          The one-norm of the balanced matrix B.
+*
+*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)
+*          If SENSE = 'E' or 'B', the reciprocal condition numbers of
+*          the eigenvalues, stored in consecutive elements of the array.
+*          For a complex conjugate pair of eigenvalues two consecutive
+*          elements of RCONDE are set to the same value. Thus RCONDE(j),
+*          RCONDV(j), and the j-th columns of VL and VR all correspond
+*          to the j-th eigenpair.
+*          If SENSE = 'N or 'V', RCONDE is not referenced.
+*
+*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)
+*          If SENSE = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the eigenvectors, stored in consecutive elements
+*          of the array. For a complex eigenvector two consecutive
+*          elements of RCONDV are set to the same value. If the
+*          eigenvalues cannot be reordered to compute RCONDV(j),
+*          RCONDV(j) is set to 0; this can only occur when the true
+*          value would be very small anyway.
+*          If SENSE = 'N' or 'E', RCONDV is not referenced.
+*
+*  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,2*N).
+*          If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
+*          LWORK >= max(1,6*N).
+*          If SENSE = 'E' or 'B', LWORK >= max(1,10*N).
+*          If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N+6)
+*          If SENSE = 'E', IWORK is not referenced.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          If SENSE = 'N', BWORK is not referenced.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  Balancing a matrix pair (A,B) includes, first, permuting rows and
+*  columns to isolate eigenvalues, second, applying diagonal similarity
+*  transformation to the rows and columns to make the rows and columns
+*  as close in norm as possible. The computed reciprocal condition
+*  numbers correspond to the balanced matrix. Permuting rows and columns
+*  will not change the condition numbers (in exact arithmetic) but
+*  diagonal scaling will.  For further explanation of balancing, see
+*  section 4.11.1.2 of LAPACK Users' Guide.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
+*
+*  An approximate error bound for the angle between the i-th computed
+*  eigenvector VL(i) or VR(i) is given by
+*
+*       EPS * norm(ABNRM, BBNRM) / DIF(i).
+*
+*  For further explanation of the reciprocal condition numbers RCONDE
+*  and RCONDV, see section 4.11 of LAPACK User's Guide.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
+     $                   PAIR, WANTSB, WANTSE, WANTSN, WANTSV
+      CHARACTER          CHTEMP
+      INTEGER            I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
+     $                   ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK,
+     $                   MINWRK, MM
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+     $                   DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC,
+     $                   DTGSNA, XERBLA 
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVL = .FALSE.
+      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVR = .FALSE.
+      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVR = .FALSE.
+      END IF
+      ILV = ILVL .OR. ILVR
+*
+      NOSCL  = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
+     $    'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( IJOBVL.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
+     $          THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -16
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV. The workspace is
+*       computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            IF( NOSCL .AND. .NOT.ILV ) THEN
+               MINWRK = 2*N
+            ELSE
+               MINWRK = 6*N
+            END IF
+            IF( WANTSE .OR. WANTSB ) THEN
+               MINWRK = 10*N
+            END IF
+            IF( WANTSV .OR. WANTSB ) THEN
+               MINWRK = MAX( MINWRK, 2*N*( N + 4 ) + 16 )
+            END IF
+            MAXWRK = MINWRK
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) )
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) )
+            IF( ILVL ) THEN
+               MAXWRK = MAX( MAXWRK, N +
+     $                       N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, 0 ) )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -26
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+      IF( ILASCL )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+      IF( ILBSCL )
+     $   CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute and/or balance the matrix pair (A,B)
+*     (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
+*
+      CALL DGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+     $             WORK, IERR )
+*
+*     Compute ABNRM and BBNRM
+*
+      ABNRM = DLANGE( '1', N, N, A, LDA, WORK( 1 ) )
+      IF( ILASCL ) THEN
+         WORK( 1 ) = ABNRM
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1,
+     $                IERR )
+         ABNRM = WORK( 1 )
+      END IF
+*
+      BBNRM = DLANGE( '1', N, N, B, LDB, WORK( 1 ) )
+      IF( ILBSCL ) THEN
+         WORK( 1 ) = BBNRM
+         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1,
+     $                IERR )
+         BBNRM = WORK( 1 )
+      END IF
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Workspace: need N, prefer N*NB )
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWRK = ITAU + IROWS
+      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to A
+*     (Workspace: need N, prefer N*NB)
+*
+      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VL and/or VR
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+      IF( ILVR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+      END IF
+*
+*     Perform QZ algorithm (Compute eigenvalues, and optionally, the
+*     Schur forms and Schur vectors)
+*     (Workspace: need N)
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+*
+      CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK,
+     $             LWORK, IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 130
+      END IF
+*
+*     Compute Eigenvectors and estimate condition numbers if desired
+*     (Workspace: DTGEVC: need 6*N
+*                 DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
+*                         need N otherwise )
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         IF( ILV ) THEN
+            IF( ILVL ) THEN
+               IF( ILVR ) THEN
+                  CHTEMP = 'B'
+               ELSE
+                  CHTEMP = 'L'
+               END IF
+            ELSE
+               CHTEMP = 'R'
+            END IF
+*
+            CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, N, IN, WORK, IERR )
+            IF( IERR.NE.0 ) THEN
+               INFO = N + 2
+               GO TO 130
+            END IF
+         END IF
+*
+         IF( .NOT.WANTSN ) THEN
+*
+*           compute eigenvectors (DTGEVC) and estimate condition
+*           numbers (DTGSNA). Note that the definition of the condition
+*           number is not invariant under transformation (u,v) to
+*           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
+*           Schur form (S,T), Q and Z are orthogonal matrices. In order
+*           to avoid using extra 2*N*N workspace, we have to recalculate
+*           eigenvectors and estimate one condition numbers at a time.
+*
+            PAIR = .FALSE.
+            DO 20 I = 1, N
+*
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+                  GO TO 20
+               END IF
+               MM = 1
+               IF( I.LT.N ) THEN
+                  IF( A( I+1, I ).NE.ZERO ) THEN
+                     PAIR = .TRUE.
+                     MM = 2
+                  END IF
+               END IF
+*
+               DO 10 J = 1, N
+                  BWORK( J ) = .FALSE.
+   10          CONTINUE
+               IF( MM.EQ.1 ) THEN
+                  BWORK( I ) = .TRUE.
+               ELSE IF( MM.EQ.2 ) THEN
+                  BWORK( I ) = .TRUE.
+                  BWORK( I+1 ) = .TRUE.
+               END IF
+*
+               IWRK = MM*N + 1
+               IWRK1 = IWRK + MM*N
+*
+*              Compute a pair of left and right eigenvectors.
+*              (compute workspace: need up to 4*N + 6*N)
+*
+               IF( WANTSE .OR. WANTSB ) THEN
+                  CALL DTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
+     $                         WORK( 1 ), N, WORK( IWRK ), N, MM, M,
+     $                         WORK( IWRK1 ), IERR )
+                  IF( IERR.NE.0 ) THEN
+                     INFO = N + 2
+                     GO TO 130
+                  END IF
+               END IF
+*
+               CALL DTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
+     $                      WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
+     $                      RCONDV( I ), MM, M, WORK( IWRK1 ),
+     $                      LWORK-IWRK1+1, IWORK, IERR )
+*
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Undo balancing on VL and VR and normalization
+*     (Workspace: none needed)
+*
+      IF( ILVL ) THEN
+         CALL DGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
+     $                LDVL, IERR )
+*
+         DO 70 JC = 1, N
+            IF( ALPHAI( JC ).LT.ZERO )
+     $         GO TO 70
+            TEMP = ZERO
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 30 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+   30          CONTINUE
+            ELSE
+               DO 40 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+     $                   ABS( VL( JR, JC+1 ) ) )
+   40          CONTINUE
+            END IF
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 70
+            TEMP = ONE / TEMP
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 50 JR = 1, N
+                  VL( JR, JC ) = VL( JR, JC )*TEMP
+   50          CONTINUE
+            ELSE
+               DO 60 JR = 1, N
+                  VL( JR, JC ) = VL( JR, JC )*TEMP
+                  VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+   60          CONTINUE
+            END IF
+   70    CONTINUE
+      END IF
+      IF( ILVR ) THEN
+         CALL DGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
+     $                LDVR, IERR )
+         DO 120 JC = 1, N
+            IF( ALPHAI( JC ).LT.ZERO )
+     $         GO TO 120
+            TEMP = ZERO
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 80 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+   80          CONTINUE
+            ELSE
+               DO 90 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+     $                   ABS( VR( JR, JC+1 ) ) )
+   90          CONTINUE
+            END IF
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 120
+            TEMP = ONE / TEMP
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 100 JR = 1, N
+                  VR( JR, JC ) = VR( JR, JC )*TEMP
+  100          CONTINUE
+            ELSE
+               DO 110 JR = 1, N
+                  VR( JR, JC ) = VR( JR, JC )*TEMP
+                  VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+  110          CONTINUE
+            END IF
+  120    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+      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
+*
+  130 CONTINUE
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of DGGEVX
+*
+      END
diff --git a/SRC/dggglm.f b/SRC/dggglm.f
new file mode 100644
index 00000000..d5e1d924
--- /dev/null
+++ b/SRC/dggglm.f
@@ -0,0 +1,258 @@
+      SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, 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, P
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
+     $                   X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGGLM solves a general Gauss-Markov linear model (GLM) problem:
+*
+*          minimize || y ||_2   subject to   d = A*x + B*y
+*              x
+*
+*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
+*  given N-vector. It is assumed that M <= N <= M+P, and
+*
+*             rank(A) = M    and    rank( A B ) = N.
+*
+*  Under these assumptions, the constrained equation is always
+*  consistent, and there is a unique solution x and a minimal 2-norm
+*  solution y, which is obtained using a generalized QR factorization
+*  of the matrices (A, B) given by
+*
+*     A = Q*(R),   B = Q*T*Z.
+*           (0)
+*
+*  In particular, if matrix B is square nonsingular, then the problem
+*  GLM is equivalent to the following weighted linear least squares
+*  problem
+*
+*               minimize || inv(B)*(d-A*x) ||_2
+*                   x
+*
+*  where inv(B) denotes the inverse of B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B.  N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  0 <= M <= N.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= N-M.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the upper triangular part of the array A contains
+*          the M-by-M upper triangular matrix R.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, D is the left hand side of the GLM equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (M)
+*  Y       (output) DOUBLE PRECISION array, dimension (P)
+*          On exit, X and Y are the solutions of the GLM problem.
+*
+*  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+M+P).
+*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          DGEQRF, SGERQF, DORMQR and SORMRQ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the upper triangular factor R associated with A in the
+*                generalized QR factorization of the pair (A, B) is
+*                singular, so that rank(A) < M; the least squares
+*                solution could not be computed.
+*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal
+*                factor T associated with B in the generalized QR
+*                factorization of the pair (A, B) is singular, so that
+*                rank( A B ) < N; the least squares solution could not
+*                be computed.
+*
+*  ===================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
+     $                   NB4, NP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMV, DGGQRF, DORMQR, DORMRQ, DTRTRS,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NP = MIN( N, P )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
+            NB2 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 )
+            NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
+            NB4 = ILAENV( 1, 'DORMRQ', ' ', N, M, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = M + NP + MAX( N, P )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGGLM', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GQR factorization of matrices A and B:
+*
+*            Q'*A = ( R11 ) M,    Q'*B*Z' = ( T11   T12 ) M
+*                   (  0  ) N-M             (  0    T22 ) N-M
+*                      M                     M+P-N  N-M
+*
+*     where R11 and T22 are upper triangular, and Q and Z are
+*     orthogonal.
+*
+      CALL DGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
+     $             WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = WORK( M+NP+1 )
+*
+*     Update left-hand-side vector d = Q'*d = ( d1 ) M
+*                                             ( d2 ) N-M
+*
+      CALL DORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D,
+     $             MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+*     Solve T22*y2 = d2 for y2
+*
+      IF( N.GT.M ) THEN
+         CALL DTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
+     $                B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+         CALL DCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
+      END IF
+*
+*     Set y1 = 0
+*
+      DO 10 I = 1, M + P - N
+         Y( I ) = ZERO
+   10 CONTINUE
+*
+*     Update d1 = d1 - T12*y2
+*
+      CALL DGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB,
+     $            Y( M+P-N+1 ), 1, ONE, D, 1 )
+*
+*     Solve triangular system: R11*x = d1
+*
+      IF( M.GT.0 ) THEN
+         CALL DTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
+     $                D, M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Copy D to X
+*
+         CALL DCOPY( M, D, 1, X, 1 )
+      END IF
+*
+*     Backward transformation y = Z'*y
+*
+      CALL DORMRQ( 'Left', 'Transpose', P, 1, NP,
+     $             B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
+     $             MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+      RETURN
+*
+*     End of DGGGLM
+*
+      END
diff --git a/SRC/dgghrd.f b/SRC/dgghrd.f
new file mode 100644
index 00000000..6b8bbb08
--- /dev/null
+++ b/SRC/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/dgglse.f b/SRC/dgglse.f
new file mode 100644
index 00000000..8a3444ea
--- /dev/null
+++ b/SRC/dgglse.f
@@ -0,0 +1,266 @@
+      SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, 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, P
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( * ), D( * ),
+     $                   WORK( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGLSE solves the linear equality-constrained least squares (LSE)
+*  problem:
+*
+*          minimize || c - A*x ||_2   subject to   B*x = d
+*
+*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
+*  M-vector, and d is a given P-vector. It is assumed that
+*  P <= N <= M+P, and
+*
+*           rank(B) = P and  rank( (A) ) = N.
+*                                ( (B) )
+*
+*  These conditions ensure that the LSE problem has a unique solution,
+*  which is obtained using a generalized RQ factorization of the
+*  matrices (B, A) given by
+*
+*     B = (0 R)*Q,   A = Z*T*Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B. 0 <= P <= N <= M+P.
+*
+*  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 T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
+*          contains the P-by-P upper triangular matrix R.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (M)
+*          On entry, C contains the right hand side vector for the
+*          least squares part of the LSE problem.
+*          On exit, the residual sum of squares for the solution
+*          is given by the sum of squares of elements N-P+1 to M of
+*          vector C.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (P)
+*          On entry, D contains the right hand side vector for the
+*          constrained equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, X is the solution of the LSE problem.
+*
+*  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+N+P).
+*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          DGEQRF, SGERQF, DORMQR and SORMRQ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the upper triangular factor R associated with B in the
+*                generalized RQ factorization of the pair (B, A) is
+*                singular, so that rank(B) < P; the least squares
+*                solution could not be computed.
+*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor
+*                T associated with A in the generalized RQ factorization
+*                of the pair (B, A) is singular, so that
+*                rank( (A) ) < N; the least squares solution could not
+*                    ( (B) )
+*                be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
+     $                   NB4, NR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DGGRQF, DORMQR, DORMRQ,
+     $                   DTRMV, DTRTRS, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+            NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+            NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, P, -1 )
+            NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = P + MN + MAX( M, N )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGLSE', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GRQ factorization of matrices B and A:
+*
+*            B*Q' = (  0  T12 ) P   Z'*A*Q' = ( R11 R12 ) N-P
+*                     N-P  P                  (  0  R22 ) M+P-N
+*                                               N-P  P
+*
+*     where T12 and R11 are upper triangular, and Q and Z are
+*     orthogonal.
+*
+      CALL DGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
+     $             WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      LOPT = WORK( P+MN+1 )
+*
+*     Update c = Z'*c = ( c1 ) N-P
+*                       ( c2 ) M+P-N
+*
+      CALL DORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ),
+     $             C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+*     Solve T12*x2 = d for x2
+*
+      IF( P.GT.0 ) THEN
+         CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
+     $                B( 1, N-P+1 ), LDB, D, P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+*        Put the solution in X
+*
+         CALL DCOPY( P, D, 1, X( N-P+1 ), 1 )
+*
+*        Update c1
+*
+         CALL DGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA,
+     $               D, 1, ONE, C, 1 )
+      END IF
+*
+*     Solve R11*x1 = c1 for x1
+*
+      IF( N.GT.P ) THEN
+         CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
+     $                A, LDA, C, N-P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Put the solutions in X
+*
+         CALL DCOPY( N-P, C, 1, X, 1 )
+      END IF
+*
+*     Compute the residual vector:
+*
+      IF( M.LT.N ) THEN
+         NR = M + P - N
+         IF( NR.GT.0 )
+     $      CALL DGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ),
+     $                  LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
+      ELSE
+         NR = P
+      END IF
+      IF( NR.GT.0 ) THEN
+         CALL DTRMV( 'Upper', 'No transpose', 'Non unit', NR,
+     $               A( N-P+1, N-P+1 ), LDA, D, 1 )
+         CALL DAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
+      END IF
+*
+*     Backward transformation x = Q'*x
+*
+      CALL DORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X,
+     $             N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+      RETURN
+*
+*     End of DGGLSE
+*
+      END
diff --git a/SRC/dggqrf.f b/SRC/dggqrf.f
new file mode 100644
index 00000000..666dc885
--- /dev/null
+++ b/SRC/dggqrf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGQRF computes a generalized QR factorization of an N-by-M matrix A
+*  and an N-by-P matrix B:
+*
+*              A = Q*R,        B = Q*T*Z,
+*
+*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+*  matrix, and R and T assume one of the forms:
+*
+*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
+*                  (  0  ) N-M                         N   M-N
+*                     M
+*
+*  where R11 is upper triangular, and
+*
+*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
+*                   P-N  N                           ( T21 ) P
+*                                                       P
+*
+*  where T12 or T21 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GQR factorization
+*  of A and B implicitly gives the QR factorization of inv(B)*A:
+*
+*               inv(B)*A = Z'*(inv(T)*R)
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  transpose of the matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B. N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
+*          upper triangular if N >= M); the elements below the diagonal,
+*          with the array TAUA, represent the orthogonal matrix Q as a
+*          product of min(N,M) elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAUA    (output) DOUBLE PRECISION array, dimension (min(N,M))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q (see Further Details).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)-th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T; the remaining
+*          elements, with the array TAUB, represent the orthogonal
+*          matrix Z as a product of elementary reflectors (see Further
+*          Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  TAUB    (output) DOUBLE PRECISION array, dimension (min(N,P))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Z (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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the QR factorization
+*          of an N-by-M matrix, NB2 is the optimal blocksize for the
+*          RQ factorization of an N-by-P matrix, and NB3 is the optimal
+*          blocksize for a call of DORMQR.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  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(n,m).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taua * v * v'
+*
+*  where taua is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+*  and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine DORGQR.
+*  To use Q to update another matrix, use LAPACK subroutine DORMQR.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(n,p).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a real scalar, and v is a real vector with
+*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
+*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine DORGRQ.
+*  To use Z to update another matrix, use LAPACK subroutine DORMRQ.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGERQF, DORMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
+      NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 )
+      NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     QR factorization of N-by-M matrix A: A = Q*R
+*
+      CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := Q'*B.
+*
+      CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
+     $             B, LDB, WORK, LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     RQ factorization of N-by-P matrix B: B = T*Z.
+*
+      CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of DGGQRF
+*
+      END
diff --git a/SRC/dggrqf.f b/SRC/dggrqf.f
new file mode 100644
index 00000000..497ee668
--- /dev/null
+++ b/SRC/dggrqf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGRQF computes a generalized RQ factorization of an M-by-N matrix A
+*  and a P-by-N matrix B:
+*
+*              A = R*Q,        B = Z*T*Q,
+*
+*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+*  matrix, and R and T assume one of the forms:
+*
+*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
+*                   N-M  M                           ( R21 ) N
+*                                                       N
+*
+*  where R12 or R21 is upper triangular, and
+*
+*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
+*                  (  0  ) P-N                         P   N-P
+*                     N
+*
+*  where T11 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GRQ factorization
+*  of A and B implicitly gives the RQ factorization of A*inv(B):
+*
+*               A*inv(B) = (R*inv(T))*Z'
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  transpose of the matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. 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 TAUA, 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).
+*
+*  TAUA    (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q (see Further Details).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
+*          upper triangular if P >= N); the elements below the diagonal,
+*          with the array TAUB, represent the orthogonal matrix Z as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TAUB    (output) DOUBLE PRECISION array, dimension (min(P,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Z (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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the RQ factorization
+*          of an M-by-N matrix, NB2 is the optimal blocksize for the
+*          QR factorization of a P-by-N matrix, and NB3 is the optimal
+*          blocksize for a call of DORMRQ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INF0= -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 - taua * v * v'
+*
+*  where taua is a real scalar, and v is a real vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine DORGRQ.
+*  To use Q to update another matrix, use LAPACK subroutine DORMRQ.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(p,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
+*  and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine DORGQR.
+*  To use Z to update another matrix, use LAPACK subroutine DORMQR.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGERQF, DORMRQ, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 )
+      NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGRQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     RQ factorization of M-by-N matrix A: A = R*Q
+*
+      CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := B*Q'
+*
+      CALL DORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ),
+     $             A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
+     $             LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     QR factorization of P-by-N matrix B: B = Z*T
+*
+      CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of DGGRQF
+*
+      END
diff --git a/SRC/dggsvd.f b/SRC/dggsvd.f
new file mode 100644
index 00000000..7e4df2b5
--- /dev/null
+++ b/SRC/dggsvd.f
@@ -0,0 +1,335 @@
+      SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
+     $                   LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), Q( LDQ, * ), U( LDU, * ),
+     $                   V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGSVD computes the generalized singular value decomposition (GSVD)
+*  of an M-by-N real matrix A and P-by-N real matrix B:
+*
+*      U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )
+*
+*  where U, V and Q are orthogonal matrices, and Z' is the transpose
+*  of Z.  Let K+L = the effective numerical rank of the matrix (A',B')',
+*  then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
+*  D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
+*  following structures, respectively:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                    K  L
+*         D2 =   L ( 0  S )
+*              P-L ( 0  0 )
+*
+*                  N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 )
+*              L (  0    0   R22 )
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                    K M-K K+L-M
+*         D1 =   K ( I  0    0   )
+*              M-K ( 0  C    0   )
+*
+*                      K M-K K+L-M
+*         D2 =   M-K ( 0  S    0  )
+*              K+L-M ( 0  0    I  )
+*                P-L ( 0  0    0  )
+*
+*                     N-K-L  K   M-K  K+L-M
+*    ( 0 R ) =     K ( 0    R11  R12  R13  )
+*                M-K ( 0     0   R22  R23  )
+*              K+L-M ( 0     0    0   R33  )
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*    S = diag( BETA(K+1),  ... , BETA(M) ),
+*    C**2 + S**2 = I.
+*
+*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
+*    ( 0  R22 R23 )
+*    in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The routine computes C, S, R, and optionally the orthogonal
+*  transformation matrices U, V and Q.
+*
+*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
+*  A and B implicitly gives the SVD of A*inv(B):
+*                       A*inv(B) = U*(D1*inv(D2))*V'.
+*  If ( A',B')' has orthonormal columns, then the GSVD of A and B is
+*  also equal to the CS decomposition of A and B. Furthermore, the GSVD
+*  can be used to derive the solution of the eigenvalue problem:
+*                       A'*A x = lambda* B'*B x.
+*  In some literature, the GSVD of A and B is presented in the form
+*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )
+*  where U and V are orthogonal and X is nonsingular, D1 and D2 are
+*  ``diagonal''.  The former GSVD form can be converted to the latter
+*  form by taking the nonsingular matrix X as
+*
+*                       X = Q*( I   0    )
+*                             ( 0 inv(R) ).
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Orthogonal matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Orthogonal matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Orthogonal matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in the Purpose section.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular matrix R, or part of R.
+*          See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains the triangular matrix R if M-K-L < 0.
+*          See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = C,
+*            BETA(K+1:K+L)  = S,
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
+*            BETA(K+1:M) =S, BETA(M+1:K+L) =1
+*          and
+*            ALPHA(K+L+1:N) = 0
+*            BETA(K+L+1:N)  = 0
+*
+*  U       (output) DOUBLE PRECISION array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) DOUBLE PRECISION array, dimension (LDV,P)
+*          If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) DOUBLE PRECISION array,
+*                      dimension (max(3*N,M,P)+N)
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (N)
+*          On exit, IWORK stores the sorting information. More
+*          precisely, the following loop will sort ALPHA
+*             for I = K+1, min(M,K+L)
+*                 swap ALPHA(I) and ALPHA(IWORK(I))
+*             endfor
+*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, the Jacobi-type procedure failed to
+*                converge.  For further details, see subroutine DTGSJA.
+*
+*  Internal Parameters
+*  ===================
+*
+*  TOLA    DOUBLE PRECISION
+*  TOLB    DOUBLE PRECISION
+*          TOLA and TOLB are the thresholds to determine the effective
+*          rank of (A',B')'. Generally, they are set to
+*                   TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+*                   TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  Further Details
+*  ===============
+*
+*  2-96 Based on modifications by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            WANTQ, WANTU, WANTV
+      INTEGER            I, IBND, ISUB, J, NCYCLE
+      DOUBLE PRECISION   ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGGSVP, DTGSJA, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGSVD', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Frobenius norm of matrices A and B
+*
+      ANORM = DLANGE( '1', M, N, A, LDA, WORK )
+      BNORM = DLANGE( '1', P, N, B, LDB, WORK )
+*
+*     Get machine precision and set up threshold for determining
+*     the effective numerical rank of the matrices A and B.
+*
+      ULP = DLAMCH( 'Precision' )
+      UNFL = DLAMCH( 'Safe Minimum' )
+      TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
+      TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
+*
+*     Preprocessing
+*
+      CALL DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
+     $             TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK,
+     $             WORK( N+1 ), INFO )
+*
+*     Compute the GSVD of two upper "triangular" matrices
+*
+      CALL DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB,
+     $             TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
+     $             WORK, NCYCLE, INFO )
+*
+*     Sort the singular values and store the pivot indices in IWORK
+*     Copy ALPHA to WORK, then sort ALPHA in WORK
+*
+      CALL DCOPY( N, ALPHA, 1, WORK, 1 )
+      IBND = MIN( L, M-K )
+      DO 20 I = 1, IBND
+*
+*        Scan for largest ALPHA(K+I)
+*
+         ISUB = I
+         SMAX = WORK( K+I )
+         DO 10 J = I + 1, IBND
+            TEMP = WORK( K+J )
+            IF( TEMP.GT.SMAX ) THEN
+               ISUB = J
+               SMAX = TEMP
+            END IF
+   10    CONTINUE
+         IF( ISUB.NE.I ) THEN
+            WORK( K+ISUB ) = WORK( K+I )
+            WORK( K+I ) = SMAX
+            IWORK( K+I ) = K + ISUB
+         ELSE
+            IWORK( K+I ) = K + I
+         END IF
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of DGGSVD
+*
+      END
diff --git a/SRC/dggsvp.f b/SRC/dggsvp.f
new file mode 100644
index 00000000..21dfe443
--- /dev/null
+++ b/SRC/dggsvp.f
@@ -0,0 +1,393 @@
+      SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
+     $                   TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,
+     $                   IWORK, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+      DOUBLE PRECISION   TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGSVP computes orthogonal matrices U, V and Q such that
+*
+*                   N-K-L  K    L
+*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
+*                L ( 0     0   A23 )
+*            M-K-L ( 0     0    0  )
+*
+*                   N-K-L  K    L
+*          =     K ( 0    A12  A13 )  if M-K-L < 0;
+*              M-K ( 0     0   A23 )
+*
+*                 N-K-L  K    L
+*   V'*B*Q =   L ( 0     0   B13 )
+*            P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
+*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the
+*  transpose of Z.
+*
+*  This decomposition is the preprocessing step for computing the
+*  Generalized Singular Value Decomposition (GSVD), see subroutine
+*  DGGSVD.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Orthogonal matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Orthogonal matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Orthogonal matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular (or trapezoidal) matrix
+*          described in the Purpose section.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains the triangular matrix described in
+*          the Purpose section.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) DOUBLE PRECISION
+*  TOLB    (input) DOUBLE PRECISION
+*          TOLA and TOLB are the thresholds to determine the effective
+*          numerical rank of matrix B and a subblock of A. Generally,
+*          they are set to
+*             TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+*             TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in Purpose.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  U       (output) DOUBLE PRECISION array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the orthogonal matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) DOUBLE PRECISION array, dimension (LDV,M)
+*          If JOBV = 'V', V contains the orthogonal matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the orthogonal matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  TAU     (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*
+*  Further Details
+*  ===============
+*
+*  The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
+*  with column pivoting to detect the effective numerical rank of the
+*  a matrix. It may be replaced by a better rank determination strategy.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORWRD, WANTQ, WANTU, WANTV
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQPF, DGEQR2, DGERQ2, DLACPY, DLAPMT, DLASET,
+     $                   DORG2R, DORM2R, DORMR2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+      FORWRD = .TRUE.
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -10
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGSVP', -INFO )
+         RETURN
+      END IF
+*
+*     QR with column pivoting of B: B*P = V*( S11 S12 )
+*                                           (  0   0  )
+*
+      DO 10 I = 1, N
+         IWORK( I ) = 0
+   10 CONTINUE
+      CALL DGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
+*
+*     Update A := A*P
+*
+      CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK )
+*
+*     Determine the effective rank of matrix B.
+*
+      L = 0
+      DO 20 I = 1, MIN( P, N )
+         IF( ABS( B( I, I ) ).GT.TOLB )
+     $      L = L + 1
+   20 CONTINUE
+*
+      IF( WANTV ) THEN
+*
+*        Copy the details of V, and form V.
+*
+         CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
+         IF( P.GT.1 )
+     $      CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
+     $                   LDV )
+         CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
+      END IF
+*
+*     Clean up B
+*
+      DO 40 J = 1, L - 1
+         DO 30 I = J + 1, L
+            B( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      IF( P.GT.L )
+     $   CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
+*
+      IF( WANTQ ) THEN
+*
+*        Set Q = I and Update Q := Q*P
+*
+         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+         CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
+      END IF
+*
+      IF( P.GE.L .AND. N.NE.L ) THEN
+*
+*        RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
+*
+         CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO )
+*
+*        Update A := A*Z'
+*
+         CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A,
+     $                LDA, WORK, INFO )
+*
+         IF( WANTQ ) THEN
+*
+*           Update Q := Q*Z'
+*
+            CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
+     $                   LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up B
+*
+         CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
+         DO 60 J = N - L + 1, N
+            DO 50 I = J - N + L + 1, L
+               B( I, J ) = ZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+      END IF
+*
+*     Let              N-L     L
+*                A = ( A11    A12 ) M,
+*
+*     then the following does the complete QR decomposition of A11:
+*
+*              A11 = U*(  0  T12 )*P1'
+*                      (  0   0  )
+*
+      DO 70 I = 1, N - L
+         IWORK( I ) = 0
+   70 CONTINUE
+      CALL DGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
+*
+*     Determine the effective rank of A11
+*
+      K = 0
+      DO 80 I = 1, MIN( M, N-L )
+         IF( ABS( A( I, I ) ).GT.TOLA )
+     $      K = K + 1
+   80 CONTINUE
+*
+*     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
+*
+      CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
+     $             TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
+*
+      IF( WANTU ) THEN
+*
+*        Copy the details of U, and form U
+*
+         CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
+         IF( M.GT.1 )
+     $      CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
+     $                   LDU )
+         CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
+      END IF
+*
+      IF( WANTQ ) THEN
+*
+*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1
+*
+         CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
+      END IF
+*
+*     Clean up A: set the strictly lower triangular part of
+*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
+*
+      DO 100 J = 1, K - 1
+         DO 90 I = J + 1, K
+            A( I, J ) = ZERO
+   90    CONTINUE
+  100 CONTINUE
+      IF( M.GT.K )
+     $   CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
+*
+      IF( N-L.GT.K ) THEN
+*
+*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
+*
+         CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
+*
+         IF( WANTQ ) THEN
+*
+*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
+*
+            CALL DORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU,
+     $                   Q, LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up A
+*
+         CALL DLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
+         DO 120 J = N - L - K + 1, N - L
+            DO 110 I = J - N + L + K + 1, K
+               A( I, J ) = ZERO
+  110       CONTINUE
+  120    CONTINUE
+*
+      END IF
+*
+      IF( M.GT.K ) THEN
+*
+*        QR factorization of A( K+1:M,N-L+1:N )
+*
+         CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
+*
+         IF( WANTU ) THEN
+*
+*           Update U(:,K+1:M) := U(:,K+1:M)*U1
+*
+            CALL DORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
+     $                   A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
+     $                   WORK, INFO )
+         END IF
+*
+*        Clean up
+*
+         DO 140 J = N - L + 1, N
+            DO 130 I = J - N + K + L + 1, M
+               A( I, J ) = ZERO
+  130       CONTINUE
+  140    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of DGGSVP
+*
+      END
diff --git a/SRC/dgtcon.f b/SRC/dgtcon.f
new file mode 100644
index 00000000..793c7f24
--- /dev/null
+++ b/SRC/dgtcon.f
@@ -0,0 +1,170 @@
+      SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, 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          NORM
+      INTEGER            INFO, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTCON estimates the reciprocal of the condition number of a real
+*  tridiagonal matrix A using the LU factorization as computed by
+*  DGTTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  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.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by DGTTRF.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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/(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            ONENRM
+      INTEGER            I, KASE, KASE1
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGTTRS, DLACN2, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is non-zero.
+*
+      DO 10 I = 1, N
+         IF( D( I ).EQ.ZERO )
+     $      RETURN
+   10 CONTINUE
+*
+      AINVNM = ZERO
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KASE = 0
+   20 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(U)*inv(L).
+*
+            CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
+     $                   WORK, N, INFO )
+         ELSE
+*
+*           Multiply by inv(L')*inv(U').
+*
+            CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK,
+     $                   N, INFO )
+         END IF
+         GO TO 20
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of DGTCON
+*
+      END
diff --git a/SRC/dgtrfs.f b/SRC/dgtrfs.f
new file mode 100644
index 00000000..4150e294
--- /dev/null
+++ b/SRC/dgtrfs.f
@@ -0,0 +1,361 @@
+      SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
+     $                   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, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is tridiagonal, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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 matrix B.  NRHS >= 0.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by DGTTRF.
+*
+*  DF      (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DUF     (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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 DGTTRS.
+*          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, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGTTRS, DLACN2, DLAGTM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -15
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'T'
+      ELSE
+         TRANSN = 'T'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 110 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
+     $                WORK( N+1 ), N )
+*
+*        Compute abs(op(A))*abs(x) + abs(b) for use in the backward
+*        error bound.
+*
+         IF( NOTRAN ) THEN
+            IF( N.EQ.1 ) THEN
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+            ELSE
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+     $                     ABS( DU( 1 )*X( 2, J ) )
+               DO 30 I = 2, N - 1
+                  WORK( I ) = ABS( B( I, J ) ) +
+     $                        ABS( DL( I-1 )*X( I-1, J ) ) +
+     $                        ABS( D( I )*X( I, J ) ) +
+     $                        ABS( DU( I )*X( I+1, J ) )
+   30          CONTINUE
+               WORK( N ) = ABS( B( N, J ) ) +
+     $                     ABS( DL( N-1 )*X( N-1, J ) ) +
+     $                     ABS( D( N )*X( N, J ) )
+            END IF
+         ELSE
+            IF( N.EQ.1 ) THEN
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+            ELSE
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+     $                     ABS( DL( 1 )*X( 2, J ) )
+               DO 40 I = 2, N - 1
+                  WORK( I ) = ABS( B( I, J ) ) +
+     $                        ABS( DU( I-1 )*X( I-1, J ) ) +
+     $                        ABS( D( I )*X( I, J ) ) +
+     $                        ABS( DL( I )*X( I+1, J ) )
+   40          CONTINUE
+               WORK( N ) = ABS( B( N, J ) ) +
+     $                     ABS( DU( N-1 )*X( N-1, J ) ) +
+     $                     ABS( D( N )*X( N, J ) )
+            END IF
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 50 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   50    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,
+     $                   WORK( N+1 ), N, INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 60 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   60    CONTINUE
+*
+         KASE = 0
+   70    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**T).
+*
+               CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+               DO 80 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+   80          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 90 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+   90          CONTINUE
+               CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 70
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 100 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  100    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of DGTRFS
+*
+      END
diff --git a/SRC/dgtsv.f b/SRC/dgtsv.f
new file mode 100644
index 00000000..79c4b71c
--- /dev/null
+++ b/SRC/dgtsv.f
@@ -0,0 +1,262 @@
+      SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTSV  solves the equation
+*
+*     A*X = B,
+*
+*  where A is an n by n tridiagonal matrix, by Gaussian elimination with
+*  partial pivoting.
+*
+*  Note that the equation  A'*X = B  may be solved by interchanging the
+*  order of the arguments DU and DL.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, DL must contain the (n-1) sub-diagonal elements of
+*          A.
+*
+*          On exit, DL is overwritten by the (n-2) elements of the
+*          second super-diagonal of the upper triangular matrix U from
+*          the LU factorization of A, in DL(1), ..., DL(n-2).
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*
+*          On exit, D is overwritten by the n diagonal elements of U.
+*
+*  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, DU must contain the (n-1) super-diagonal elements
+*          of A.
+*
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          super-diagonal of U.
+*
+*  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, and the solution
+*               has not been computed.  The factorization has not been
+*               completed unless i = N.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   FACT, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGTSV ', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( NRHS.EQ.1 ) THEN
+         DO 10 I = 1, N - 2
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+*              No row interchange required
+*
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+               DL( I ) = ZERO
+            ELSE
+*
+*              Interchange rows I and I+1
+*
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DL( I ) = DU( I+1 )
+               DU( I+1 ) = -FACT*DL( I )
+               DU( I ) = TEMP
+               TEMP = B( I, 1 )
+               B( I, 1 ) = B( I+1, 1 )
+               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+            END IF
+   10    CONTINUE
+         IF( N.GT.1 ) THEN
+            I = N - 1
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+            ELSE
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DU( I ) = TEMP
+               TEMP = B( I, 1 )
+               B( I, 1 ) = B( I+1, 1 )
+               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+            END IF
+         END IF
+         IF( D( N ).EQ.ZERO ) THEN
+            INFO = N
+            RETURN
+         END IF
+      ELSE
+         DO 40 I = 1, N - 2
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+*              No row interchange required
+*
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  DO 20 J = 1, NRHS
+                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+   20             CONTINUE
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+               DL( I ) = ZERO
+            ELSE
+*
+*              Interchange rows I and I+1
+*
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DL( I ) = DU( I+1 )
+               DU( I+1 ) = -FACT*DL( I )
+               DU( I ) = TEMP
+               DO 30 J = 1, NRHS
+                  TEMP = B( I, J )
+                  B( I, J ) = B( I+1, J )
+                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
+   30          CONTINUE
+            END IF
+   40    CONTINUE
+         IF( N.GT.1 ) THEN
+            I = N - 1
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  DO 50 J = 1, NRHS
+                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+   50             CONTINUE
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+            ELSE
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DU( I ) = TEMP
+               DO 60 J = 1, NRHS
+                  TEMP = B( I, J )
+                  B( I, J ) = B( I+1, J )
+                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
+   60          CONTINUE
+            END IF
+         END IF
+         IF( D( N ).EQ.ZERO ) THEN
+            INFO = N
+            RETURN
+         END IF
+      END IF
+*
+*     Back solve with the matrix U from the factorization.
+*
+      IF( NRHS.LE.2 ) THEN
+         J = 1
+   70    CONTINUE
+         B( N, J ) = B( N, J ) / D( N )
+         IF( N.GT.1 )
+     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
+         DO 80 I = N - 2, 1, -1
+            B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+     $                  B( I+2, J ) ) / D( I )
+   80    CONTINUE
+         IF( J.LT.NRHS ) THEN
+            J = J + 1
+            GO TO 70
+         END IF
+      ELSE
+         DO 100 J = 1, NRHS
+            B( N, J ) = B( N, J ) / D( N )
+            IF( N.GT.1 )
+     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                       D( N-1 )
+            DO 90 I = N - 2, 1, -1
+               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+     $                     B( I+2, J ) ) / D( I )
+   90       CONTINUE
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DGTSV
+*
+      END
diff --git a/SRC/dgtsvx.f b/SRC/dgtsvx.f
new file mode 100644
index 00000000..76167b84
--- /dev/null
+++ b/SRC/dgtsvx.f
@@ -0,0 +1,291 @@
+      SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
+     $                   DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTSVX uses the LU factorization to compute the solution to a real
+*  system of linear equations A * X = B or A**T * X = B,
+*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A
+*     as A = L * U, where L is a product of permutation and unit lower
+*     bidiagonal matrices and U is upper triangular with nonzeros in
+*     only the main diagonal and first two superdiagonals.
+*
+*  2. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored
+*                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
+*                  will not be modified.
+*          = 'N':  The matrix will be copied to DLF, DF, and DUF
+*                  and factored.
+*
+*  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 matrix B.  NRHS >= 0.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of A.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input or output) DOUBLE PRECISION array, dimension (N-1)
+*          If FACT = 'F', then DLF is an input argument and on entry
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A as computed by DGTTRF.
+*
+*          If FACT = 'N', then DLF is an output argument and on exit
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A.
+*
+*  DF      (input or output) DOUBLE PRECISION array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*  DUF     (input or output) DOUBLE PRECISION array, dimension (N-1)
+*          If FACT = 'F', then DUF is an input argument and on entry
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*          If FACT = 'N', then DUF is an output argument and on exit
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input or output) DOUBLE PRECISION array, dimension (N-2)
+*          If FACT = 'F', then DU2 is an input argument and on entry
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*          If FACT = 'N', then DU2 is an output argument and on exit
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*  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 LU factorization of A as
+*          computed by DGTTRF.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the LU factorization of A;
+*          row i of the matrix was interchanged with row IPIV(i).
+*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
+*          a row interchange was not required.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix 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.
+*
+*  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.  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  U(i,i) is exactly zero.  The factorization
+*                       has not been completed unless i = N, but the
+*                       factor U is exactly singular, so the solution
+*                       and error bounds could not be computed.
+*                       RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT, NOTRAN
+      CHARACTER          NORM
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANGT
+      EXTERNAL           LSAME, DLAMCH, DLANGT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the LU factorization of A.
+*
+         CALL DCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 ) THEN
+            CALL DCOPY( N-1, DL, 1, DLF, 1 )
+            CALL DCOPY( N-1, DU, 1, DUF, 1 )
+         END IF
+         CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = DLANGT( NORM, N, DL, D, DU )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
+     $             IWORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of DGTSVX
+*
+      END
diff --git a/SRC/dgttrf.f b/SRC/dgttrf.f
new file mode 100644
index 00000000..b39527ef
--- /dev/null
+++ b/SRC/dgttrf.f
@@ -0,0 +1,168 @@
+      SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, 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 ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTTRF computes an LU factorization of a real tridiagonal matrix A
+*  using elimination with partial pivoting and row interchanges.
+*
+*  The factorization has the form
+*     A = L * U
+*  where L is a product of permutation and unit lower bidiagonal
+*  matrices and U is upper triangular with nonzeros in only the main
+*  diagonal and first two superdiagonals.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, DL must contain the (n-1) sub-diagonal elements of
+*          A.
+*
+*          On exit, DL is overwritten by the (n-1) multipliers that
+*          define the matrix L from the LU factorization of A.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*
+*          On exit, D is overwritten by the n diagonal elements of the
+*          upper triangular matrix U from the LU factorization of A.
+*
+*  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, DU must contain the (n-1) super-diagonal elements
+*          of A.
+*
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          super-diagonal of U.
+*
+*  DU2     (output) DOUBLE PRECISION array, dimension (N-2)
+*          On exit, DU2 is overwritten by the (n-2) elements of the
+*          second super-diagonal of U.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   FACT, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'DGTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize IPIV(i) = i and DU2(I) = 0
+*
+      DO 10 I = 1, N
+         IPIV( I ) = I
+   10 CONTINUE
+      DO 20 I = 1, N - 2
+         DU2( I ) = ZERO
+   20 CONTINUE
+*
+      DO 30 I = 1, N - 2
+         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+*           No row interchange required, eliminate DL(I)
+*
+            IF( D( I ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+*
+*           Interchange rows I and I+1, eliminate DL(I)
+*
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            DU2( I ) = DU( I+1 )
+            DU( I+1 ) = -FACT*DU( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+   30 CONTINUE
+      IF( N.GT.1 ) THEN
+         I = N - 1
+         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+            IF( D( I ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+      END IF
+*
+*     Check for a zero on the diagonal of U.
+*
+      DO 40 I = 1, N
+         IF( D( I ).EQ.ZERO ) THEN
+            INFO = I
+            GO TO 50
+         END IF
+   40 CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of DGTTRF
+*
+      END
diff --git a/SRC/dgttrs.f b/SRC/dgttrs.f
new file mode 100644
index 00000000..318d6a75
--- /dev/null
+++ b/SRC/dgttrs.f
@@ -0,0 +1,140 @@
+      SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTTRS solves one of the systems of equations
+*     A*X = B  or  A'*X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by DGTTRF.
+*
+*  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.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            ITRANS, J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGTTS2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
+      IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
+     $    't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Decode TRANS
+*
+      IF( NOTRAN ) THEN
+         ITRANS = 0
+      ELSE
+         ITRANS = 1
+      END IF
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) )
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
+     $                   LDB )
+   10    CONTINUE
+      END IF
+*
+*     End of DGTTRS
+*
+      END
diff --git a/SRC/dgtts2.f b/SRC/dgtts2.f
new file mode 100644
index 00000000..4b123ab7
--- /dev/null
+++ b/SRC/dgtts2.f
@@ -0,0 +1,196 @@
+      SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ITRANS, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGTTS2 solves one of the systems of equations
+*     A*X = B  or  A'*X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by DGTTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITRANS  (input) INTEGER
+*          Specifies the form of the system of equations.
+*          = 0:  A * X = B  (No transpose)
+*          = 1:  A'* X = B  (Transpose)
+*          = 2:  A'* X = B  (Conjugate transpose = Transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IP, J
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( ITRANS.EQ.0 ) THEN
+*
+*        Solve A*X = B using the LU factorization of A,
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+   10       CONTINUE
+*
+*           Solve L*x = b.
+*
+            DO 20 I = 1, N - 1
+               IP = IPIV( I )
+               TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
+               B( I, J ) = B( IP, J )
+               B( I+1, J ) = TEMP
+   20       CONTINUE
+*
+*           Solve U*x = b.
+*
+            B( N, J ) = B( N, J ) / D( N )
+            IF( N.GT.1 )
+     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                       D( N-1 )
+            DO 30 I = N - 2, 1, -1
+               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                     B( I+2, J ) ) / D( I )
+   30       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 10
+            END IF
+         ELSE
+            DO 60 J = 1, NRHS
+*
+*              Solve L*x = b.
+*
+               DO 40 I = 1, N - 1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+                  ELSE
+                     TEMP = B( I, J )
+                     B( I, J ) = B( I+1, J )
+                     B( I+1, J ) = TEMP - DL( I )*B( I, J )
+                  END IF
+   40          CONTINUE
+*
+*              Solve U*x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               IF( N.GT.1 )
+     $            B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                          D( N-1 )
+               DO 50 I = N - 2, 1, -1
+                  B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                        B( I+2, J ) ) / D( I )
+   50          CONTINUE
+   60       CONTINUE
+         END IF
+      ELSE
+*
+*        Solve A' * X = B.
+*
+         IF( NRHS.LE.1 ) THEN
+*
+*           Solve U'*x = b.
+*
+            J = 1
+   70       CONTINUE
+            B( 1, J ) = B( 1, J ) / D( 1 )
+            IF( N.GT.1 )
+     $         B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+            DO 80 I = 3, N
+               B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
+     $                     B( I-2, J ) ) / D( I )
+   80       CONTINUE
+*
+*           Solve L'*x = b.
+*
+            DO 90 I = N - 1, 1, -1
+               IP = IPIV( I )
+               TEMP = B( I, J ) - DL( I )*B( I+1, J )
+               B( I, J ) = B( IP, J )
+               B( IP, J ) = TEMP
+   90       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 70
+            END IF
+*
+         ELSE
+            DO 120 J = 1, NRHS
+*
+*              Solve U'*x = b.
+*
+               B( 1, J ) = B( 1, J ) / D( 1 )
+               IF( N.GT.1 )
+     $            B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+               DO 100 I = 3, N
+                  B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
+     $                        DU2( I-2 )*B( I-2, J ) ) / D( I )
+  100          CONTINUE
+               DO 110 I = N - 1, 1, -1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+                  ELSE
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+                     B( I, J ) = TEMP
+                  END IF
+  110          CONTINUE
+  120       CONTINUE
+         END IF
+      END IF
+*
+*     End of DGTTS2
+*
+      END
diff --git a/SRC/dhgeqz.f b/SRC/dhgeqz.f
new file mode 100644
index 00000000..de137dc1
--- /dev/null
+++ b/SRC/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/dhsein.f b/SRC/dhsein.f
new file mode 100644
index 00000000..9b4aa311
--- /dev/null
+++ b/SRC/dhsein.f
@@ -0,0 +1,411 @@
+      SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
+     $                   VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
+     $                   IFAILR, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EIGSRC, INITV, SIDE
+      INTEGER            INFO, LDH, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IFAILL( * ), IFAILR( * )
+      DOUBLE PRECISION   H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WI( * ), WORK( * ), WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DHSEIN uses inverse iteration to find specified right and/or left
+*  eigenvectors of a real upper Hessenberg matrix H.
+*
+*  The right eigenvector x and the left eigenvector y of the matrix H
+*  corresponding to an eigenvalue w are defined by:
+*
+*               H * x = w * x,     y**h * H = w * y**h
+*
+*  where y**h denotes the conjugate transpose of the vector y.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R': compute right eigenvectors only;
+*          = 'L': compute left eigenvectors only;
+*          = 'B': compute both right and left eigenvectors.
+*
+*  EIGSRC  (input) CHARACTER*1
+*          Specifies the source of eigenvalues supplied in (WR,WI):
+*          = 'Q': the eigenvalues were found using DHSEQR; thus, if
+*                 H has zero subdiagonal elements, and so is
+*                 block-triangular, then the j-th eigenvalue can be
+*                 assumed to be an eigenvalue of the block containing
+*                 the j-th row/column.  This property allows DHSEIN to
+*                 perform inverse iteration on just one diagonal block.
+*          = 'N': no assumptions are made on the correspondence
+*                 between eigenvalues and diagonal blocks.  In this
+*                 case, DHSEIN must always perform inverse iteration
+*                 using the whole matrix H.
+*
+*  INITV   (input) CHARACTER*1
+*          = 'N': no initial vectors are supplied;
+*          = 'U': user-supplied initial vectors are stored in the arrays
+*                 VL and/or VR.
+*
+*  SELECT  (input/output) LOGICAL array, dimension (N)
+*          Specifies the eigenvectors to be computed. To select the
+*          real eigenvector corresponding to a real eigenvalue WR(j),
+*          SELECT(j) must be set to .TRUE.. To select the complex
+*          eigenvector corresponding to a complex eigenvalue
+*          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
+*          either SELECT(j) or SELECT(j+1) or both must be set to
+*          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
+*          .FALSE..
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) DOUBLE PRECISION array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  WR      (input/output) DOUBLE PRECISION array, dimension (N)
+*  WI      (input) DOUBLE PRECISION array, dimension (N)
+*          On entry, the real and imaginary parts of the eigenvalues of
+*          H; a complex conjugate pair of eigenvalues must be stored in
+*          consecutive elements of WR and WI.
+*          On exit, WR may have been altered since close eigenvalues
+*          are perturbed slightly in searching for independent
+*          eigenvectors.
+*
+*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
+*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
+*          contain starting vectors for the inverse iteration for the
+*          left eigenvectors; the starting vector for each eigenvector
+*          must be in the same column(s) in which the eigenvector will
+*          be stored.
+*          On exit, if SIDE = 'L' or 'B', the left eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VL, in the same order as their eigenvalues. A
+*          complex eigenvector corresponding to a complex eigenvalue is
+*          stored in two consecutive columns, the first holding the real
+*          part and the second the imaginary part.
+*          If SIDE = 'R', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
+*
+*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
+*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
+*          contain starting vectors for the inverse iteration for the
+*          right eigenvectors; the starting vector for each eigenvector
+*          must be in the same column(s) in which the eigenvector will
+*          be stored.
+*          On exit, if SIDE = 'R' or 'B', the right eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VR, in the same order as their eigenvalues. A
+*          complex eigenvector corresponding to a complex eigenvalue is
+*          stored in two consecutive columns, the first holding the real
+*          part and the second the imaginary part.
+*          If SIDE = 'L', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
+*
+*  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 required to
+*          store the eigenvectors; each selected real eigenvector
+*          occupies one column and each selected complex eigenvector
+*          occupies two columns.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)
+*
+*  IFAILL  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
+*          eigenvector in the i-th column of VL (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
+*          eigenvector converged satisfactorily. If the i-th and (i+1)th
+*          columns of VL hold a complex eigenvector, then IFAILL(i) and
+*          IFAILL(i+1) are set to the same value.
+*          If SIDE = 'R', IFAILL is not referenced.
+*
+*  IFAILR  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
+*          eigenvector in the i-th column of VR (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
+*          eigenvector converged satisfactorily. If the i-th and (i+1)th
+*          columns of VR hold a complex eigenvector, then IFAILR(i) and
+*          IFAILR(i+1) are set to the same value.
+*          If SIDE = 'L', IFAILR is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, i is the number of eigenvectors which
+*                failed to converge; see IFAILL and IFAILR for further
+*                details.
+*
+*  Further Details
+*  ===============
+*
+*  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            BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
+      INTEGER            I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
+      DOUBLE PRECISION   BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
+     $                   WKR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANHS
+      EXTERNAL           LSAME, DLAMCH, DLANHS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAEIN, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters.
+*
+      BOTHV = LSAME( SIDE, 'B' )
+      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+      FROMQR = LSAME( EIGSRC, 'Q' )
+*
+      NOINIT = LSAME( INITV, 'N' )
+*
+*     Set M to the number of columns required to store the selected
+*     eigenvectors, and standardize the array SELECT.
+*
+      M = 0
+      PAIR = .FALSE.
+      DO 10 K = 1, N
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+            SELECT( K ) = .FALSE.
+         ELSE
+            IF( WI( K ).EQ.ZERO ) THEN
+               IF( SELECT( K ) )
+     $            M = M + 1
+            ELSE
+               PAIR = .TRUE.
+               IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
+                  SELECT( K ) = .TRUE.
+                  M = M + 2
+               END IF
+            END IF
+         END IF
+   10 CONTINUE
+*
+      INFO = 0
+      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -1
+      ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+         INFO = -11
+      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DHSEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set machine-dependent constants.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( N / ULP )
+      BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+      LDWORK = N + 1
+*
+      KL = 1
+      KLN = 0
+      IF( FROMQR ) THEN
+         KR = 0
+      ELSE
+         KR = N
+      END IF
+      KSR = 1
+*
+      DO 120 K = 1, N
+         IF( SELECT( K ) ) THEN
+*
+*           Compute eigenvector(s) corresponding to W(K).
+*
+            IF( FROMQR ) THEN
+*
+*              If affiliation of eigenvalues is known, check whether
+*              the matrix splits.
+*
+*              Determine KL and KR such that 1 <= KL <= K <= KR <= N
+*              and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
+*              KR = N).
+*
+*              Then inverse iteration can be performed with the
+*              submatrix H(KL:N,KL:N) for a left eigenvector, and with
+*              the submatrix H(1:KR,1:KR) for a right eigenvector.
+*
+               DO 20 I = K, KL + 1, -1
+                  IF( H( I, I-1 ).EQ.ZERO )
+     $               GO TO 30
+   20          CONTINUE
+   30          CONTINUE
+               KL = I
+               IF( K.GT.KR ) THEN
+                  DO 40 I = K, N - 1
+                     IF( H( I+1, I ).EQ.ZERO )
+     $                  GO TO 50
+   40             CONTINUE
+   50             CONTINUE
+                  KR = I
+               END IF
+            END IF
+*
+            IF( KL.NE.KLN ) THEN
+               KLN = KL
+*
+*              Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
+*              has not ben computed before.
+*
+               HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
+               IF( HNORM.GT.ZERO ) THEN
+                  EPS3 = HNORM*ULP
+               ELSE
+                  EPS3 = SMLNUM
+               END IF
+            END IF
+*
+*           Perturb eigenvalue if it is close to any previous
+*           selected eigenvalues affiliated to the submatrix
+*           H(KL:KR,KL:KR). Close roots are modified by EPS3.
+*
+            WKR = WR( K )
+            WKI = WI( K )
+   60       CONTINUE
+            DO 70 I = K - 1, KL, -1
+               IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
+     $             ABS( WI( I )-WKI ).LT.EPS3 ) THEN
+                  WKR = WKR + EPS3
+                  GO TO 60
+               END IF
+   70       CONTINUE
+            WR( K ) = WKR
+*
+            PAIR = WKI.NE.ZERO
+            IF( PAIR ) THEN
+               KSI = KSR + 1
+            ELSE
+               KSI = KSR
+            END IF
+            IF( LEFTV ) THEN
+*
+*              Compute left eigenvector.
+*
+               CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
+     $                      WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
+     $                      WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
+     $                      BIGNUM, IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  IF( PAIR ) THEN
+                     INFO = INFO + 2
+                  ELSE
+                     INFO = INFO + 1
+                  END IF
+                  IFAILL( KSR ) = K
+                  IFAILL( KSI ) = K
+               ELSE
+                  IFAILL( KSR ) = 0
+                  IFAILL( KSI ) = 0
+               END IF
+               DO 80 I = 1, KL - 1
+                  VL( I, KSR ) = ZERO
+   80          CONTINUE
+               IF( PAIR ) THEN
+                  DO 90 I = 1, KL - 1
+                     VL( I, KSI ) = ZERO
+   90             CONTINUE
+               END IF
+            END IF
+            IF( RIGHTV ) THEN
+*
+*              Compute right eigenvector.
+*
+               CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
+     $                      VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
+     $                      WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
+     $                      IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  IF( PAIR ) THEN
+                     INFO = INFO + 2
+                  ELSE
+                     INFO = INFO + 1
+                  END IF
+                  IFAILR( KSR ) = K
+                  IFAILR( KSI ) = K
+               ELSE
+                  IFAILR( KSR ) = 0
+                  IFAILR( KSI ) = 0
+               END IF
+               DO 100 I = KR + 1, N
+                  VR( I, KSR ) = ZERO
+  100          CONTINUE
+               IF( PAIR ) THEN
+                  DO 110 I = KR + 1, N
+                     VR( I, KSI ) = ZERO
+  110             CONTINUE
+               END IF
+            END IF
+*
+            IF( PAIR ) THEN
+               KSR = KSR + 2
+            ELSE
+               KSR = KSR + 1
+            END IF
+         END IF
+  120 CONTINUE
+*
+      RETURN
+*
+*     End of DHSEIN
+*
+      END
diff --git a/SRC/dhseqr.f b/SRC/dhseqr.f
new file mode 100644
index 00000000..5b307fa8
--- /dev/null
+++ b/SRC/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/disnan.f b/SRC/disnan.f
new file mode 100644
index 00000000..bcfd71c9
--- /dev/null
+++ b/SRC/disnan.f
@@ -0,0 +1,33 @@
+      FUNCTION DISNAN( DIN )
+      LOGICAL DISNAN
+*
+*  -- 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 )
+      END FUNCTION
diff --git a/SRC/dlabad.f b/SRC/dlabad.f
new file mode 100644
index 00000000..05ff5d44
--- /dev/null
+++ b/SRC/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/dlabrd.f b/SRC/dlabrd.f
new file mode 100644
index 00000000..196b130c
--- /dev/null
+++ b/SRC/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/dlacn2.f b/SRC/dlacn2.f
new file mode 100644
index 00000000..6705d256
--- /dev/null
+++ b/SRC/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/dlacon.f b/SRC/dlacon.f
new file mode 100644
index 00000000..f113b03a
--- /dev/null
+++ b/SRC/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/dlacpy.f b/SRC/dlacpy.f
new file mode 100644
index 00000000..d72603a5
--- /dev/null
+++ b/SRC/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/dladiv.f b/SRC/dladiv.f
new file mode 100644
index 00000000..b6a74d1b
--- /dev/null
+++ b/SRC/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/dlae2.f b/SRC/dlae2.f
new file mode 100644
index 00000000..8e81c608
--- /dev/null
+++ b/SRC/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/dlaebz.f b/SRC/dlaebz.f
new file mode 100644
index 00000000..dec0c362
--- /dev/null
+++ b/SRC/dlaebz.f
@@ -0,0 +1,551 @@
+      SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
+     $                   RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
+     $                   NAB, WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
+      DOUBLE PRECISION   ABSTOL, PIVMIN, RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * ), NAB( MMAX, * ), NVAL( * )
+      DOUBLE PRECISION   AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAEBZ contains the iteration loops which compute and use the
+*  function N(w), which is the count of eigenvalues of a symmetric
+*  tridiagonal matrix T less than or equal to its argument  w.  It
+*  performs a choice of two types of loops:
+*
+*  IJOB=1, followed by
+*  IJOB=2: It takes as input a list of intervals and returns a list of
+*          sufficiently small intervals whose union contains the same
+*          eigenvalues as the union of the original intervals.
+*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
+*          The output interval (AB(j,1),AB(j,2)] will contain
+*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
+*
+*  IJOB=3: It performs a binary search in each input interval
+*          (AB(j,1),AB(j,2)] for a point  w(j)  such that
+*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of
+*          the search.  If such a w(j) is found, then on output
+*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output
+*          (AB(j,1),AB(j,2)] will be a small interval containing the
+*          point where N(w) jumps through NVAL(j), unless that point
+*          lies outside the initial interval.
+*
+*  Note that the intervals are in all cases half-open intervals,
+*  i.e., of the form  (a,b] , which includes  b  but not  a .
+*
+*  To avoid underflow, the matrix should be scaled so that its largest
+*  element is no greater than  overflow**(1/2) * underflow**(1/4)
+*  in absolute value.  To assure the most accurate computation
+*  of small eigenvalues, the matrix should be scaled to be
+*  not much smaller than that, either.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966
+*
+*  Note: the arguments are, in general, *not* checked for unreasonable
+*  values.
+*
+*  Arguments
+*  =========
+*
+*  IJOB    (input) INTEGER
+*          Specifies what is to be done:
+*          = 1:  Compute NAB for the initial intervals.
+*          = 2:  Perform bisection iteration to find eigenvalues of T.
+*          = 3:  Perform bisection iteration to invert N(w), i.e.,
+*                to find a point which has a specified number of
+*                eigenvalues of T to its left.
+*          Other values will cause DLAEBZ to return with INFO=-1.
+*
+*  NITMAX  (input) INTEGER
+*          The maximum number of "levels" of bisection to be
+*          performed, i.e., an interval of width W will not be made
+*          smaller than 2^(-NITMAX) * W.  If not all intervals
+*          have converged after NITMAX iterations, then INFO is set
+*          to the number of non-converged intervals.
+*
+*  N       (input) INTEGER
+*          The dimension n of the tridiagonal matrix T.  It must be at
+*          least 1.
+*
+*  MMAX    (input) INTEGER
+*          The maximum number of intervals.  If more than MMAX intervals
+*          are generated, then DLAEBZ will quit with INFO=MMAX+1.
+*
+*  MINP    (input) INTEGER
+*          The initial number of intervals.  It may not be greater than
+*          MMAX.
+*
+*  NBMIN   (input) INTEGER
+*          The smallest number of intervals that should be processed
+*          using a vector loop.  If zero, then only the scalar loop
+*          will be used.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The minimum (absolute) width of an interval.  When an
+*          interval is narrower than ABSTOL, or than RELTOL times the
+*          larger (in magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  This must be at least
+*          zero.
+*
+*  RELTOL  (input) DOUBLE PRECISION
+*          The minimum relative width of an interval.  When an interval
+*          is narrower than ABSTOL, or than RELTOL times the larger (in
+*          magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  Note: this should
+*          always be at least radix*machine epsilon.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum absolute value of a "pivot" in the Sturm
+*          sequence loop.  This *must* be at least  max |e(j)**2| *
+*          safe_min  and at least safe_min, where safe_min is at least
+*          the smallest number that can divide one without overflow.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N)
+*          The offdiagonal elements of the tridiagonal matrix T in
+*          positions 1 through N-1.  E(N) is arbitrary.
+*
+*  E2      (input) DOUBLE PRECISION array, dimension (N)
+*          The squares of the offdiagonal elements of the tridiagonal
+*          matrix T.  E2(N) is ignored.
+*
+*  NVAL    (input/output) INTEGER array, dimension (MINP)
+*          If IJOB=1 or 2, not referenced.
+*          If IJOB=3, the desired values of N(w).  The elements of NVAL
+*          will be reordered to correspond with the intervals in AB.
+*          Thus, NVAL(j) on output will not, in general be the same as
+*          NVAL(j) on input, but it will correspond with the interval
+*          (AB(j,1),AB(j,2)] on output.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (MMAX,2)
+*          The endpoints of the intervals.  AB(j,1) is  a(j), the left
+*          endpoint of the j-th interval, and AB(j,2) is b(j), the
+*          right endpoint of the j-th interval.  The input intervals
+*          will, in general, be modified, split, and reordered by the
+*          calculation.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (MMAX)
+*          If IJOB=1, ignored.
+*          If IJOB=2, workspace.
+*          If IJOB=3, then on input C(j) should be initialized to the
+*          first search point in the binary search.
+*
+*  MOUT    (output) INTEGER
+*          If IJOB=1, the number of eigenvalues in the intervals.
+*          If IJOB=2 or 3, the number of intervals output.
+*          If IJOB=3, MOUT will equal MINP.
+*
+*  NAB     (input/output) INTEGER array, dimension (MMAX,2)
+*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
+*          If IJOB=2, then on input, NAB(i,j) should be set.  It must
+*             satisfy the condition:
+*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
+*             which means that in interval i only eigenvalues
+*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually,
+*             NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with
+*             IJOB=1.
+*             On output, NAB(i,j) will contain
+*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
+*             the input interval that the output interval
+*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
+*             the input values of NAB(k,1) and NAB(k,2).
+*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
+*             unless N(w) > NVAL(i) for all search points  w , in which
+*             case NAB(i,1) will not be modified, i.e., the output
+*             value will be the same as the input value (modulo
+*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
+*             for all search points  w , in which case NAB(i,2) will
+*             not be modified.  Normally, NAB should be set to some
+*             distinctive value(s) before DLAEBZ is called.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MMAX)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MMAX)
+*          Workspace.
+*
+*  INFO    (output) INTEGER
+*          = 0:       All intervals converged.
+*          = 1--MMAX: The last INFO intervals did not converge.
+*          = MMAX+1:  More than MMAX intervals were generated.
+*
+*  Further Details
+*  ===============
+*
+*      This routine is intended to be called only by other LAPACK
+*  routines, thus the interface is less user-friendly.  It is intended
+*  for two purposes:
+*
+*  (a) finding eigenvalues.  In this case, DLAEBZ should have one or
+*      more initial intervals set up in AB, and DLAEBZ should be called
+*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.
+*      Intervals with no eigenvalues would usually be thrown out at
+*      this point.  Also, if not all the eigenvalues in an interval i
+*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
+*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
+*      eigenvalue.  DLAEBZ is then called with IJOB=2 and MMAX
+*      no smaller than the value of MOUT returned by the call with
+*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1
+*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
+*      tolerance specified by ABSTOL and RELTOL.
+*
+*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
+*      In this case, start with a Gershgorin interval  (a,b).  Set up
+*      AB to contain 2 search intervals, both initially (a,b).  One
+*      NVAL element should contain  f-1  and the other should contain  l
+*      , while C should contain a and b, resp.  NAB(i,1) should be -1
+*      and NAB(i,2) should be N+1, to flag an error if the desired
+*      interval does not lie in (a,b).  DLAEBZ is then called with
+*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --
+*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
+*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
+*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and
+*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and
+*      w(l-r)=...=w(l+k) are handled similarly.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, TWO, HALF
+      PARAMETER          ( ZERO = 0.0D0, TWO = 2.0D0,
+     $                   HALF = 1.0D0 / TWO )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
+     $                   KLNEW
+      DOUBLE PRECISION   TMP1, TMP2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Check for Errors
+*
+      INFO = 0
+      IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
+         INFO = -1
+         RETURN
+      END IF
+*
+*     Initialize NAB
+*
+      IF( IJOB.EQ.1 ) THEN
+*
+*        Compute the number of eigenvalues in the initial intervals.
+*
+         MOUT = 0
+*DIR$ NOVECTOR
+         DO 30 JI = 1, MINP
+            DO 20 JP = 1, 2
+               TMP1 = D( 1 ) - AB( JI, JP )
+               IF( ABS( TMP1 ).LT.PIVMIN )
+     $            TMP1 = -PIVMIN
+               NAB( JI, JP ) = 0
+               IF( TMP1.LE.ZERO )
+     $            NAB( JI, JP ) = 1
+*
+               DO 10 J = 2, N
+                  TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
+                  IF( ABS( TMP1 ).LT.PIVMIN )
+     $               TMP1 = -PIVMIN
+                  IF( TMP1.LE.ZERO )
+     $               NAB( JI, JP ) = NAB( JI, JP ) + 1
+   10          CONTINUE
+   20       CONTINUE
+            MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
+   30    CONTINUE
+         RETURN
+      END IF
+*
+*     Initialize for loop
+*
+*     KF and KL have the following meaning:
+*        Intervals 1,...,KF-1 have converged.
+*        Intervals KF,...,KL  still need to be refined.
+*
+      KF = 1
+      KL = MINP
+*
+*     If IJOB=2, initialize C.
+*     If IJOB=3, use the user-supplied starting point.
+*
+      IF( IJOB.EQ.2 ) THEN
+         DO 40 JI = 1, MINP
+            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+   40    CONTINUE
+      END IF
+*
+*     Iteration loop
+*
+      DO 130 JIT = 1, NITMAX
+*
+*        Loop over intervals
+*
+         IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
+*
+*           Begin of Parallel Version of the loop
+*
+            DO 60 JI = KF, KL
+*
+*              Compute N(c), the number of eigenvalues less than c
+*
+               WORK( JI ) = D( 1 ) - C( JI )
+               IWORK( JI ) = 0
+               IF( WORK( JI ).LE.PIVMIN ) THEN
+                  IWORK( JI ) = 1
+                  WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+               END IF
+*
+               DO 50 J = 2, N
+                  WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
+                  IF( WORK( JI ).LE.PIVMIN ) THEN
+                     IWORK( JI ) = IWORK( JI ) + 1
+                     WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+                  END IF
+   50          CONTINUE
+   60       CONTINUE
+*
+            IF( IJOB.LE.2 ) THEN
+*
+*              IJOB=2: Choose all intervals containing eigenvalues.
+*
+               KLNEW = KL
+               DO 70 JI = KF, KL
+*
+*                 Insure that N(w) is monotone
+*
+                  IWORK( JI ) = MIN( NAB( JI, 2 ),
+     $                          MAX( NAB( JI, 1 ), IWORK( JI ) ) )
+*
+*                 Update the Queue -- add intervals if both halves
+*                 contain eigenvalues.
+*
+                  IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
+*
+*                    No eigenvalue in the upper interval:
+*                    just use the lower interval.
+*
+                     AB( JI, 2 ) = C( JI )
+*
+                  ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
+*
+*                    No eigenvalue in the lower interval:
+*                    just use the upper interval.
+*
+                     AB( JI, 1 ) = C( JI )
+                  ELSE
+                     KLNEW = KLNEW + 1
+                     IF( KLNEW.LE.MMAX ) THEN
+*
+*                       Eigenvalue in both intervals -- add upper to
+*                       queue.
+*
+                        AB( KLNEW, 2 ) = AB( JI, 2 )
+                        NAB( KLNEW, 2 ) = NAB( JI, 2 )
+                        AB( KLNEW, 1 ) = C( JI )
+                        NAB( KLNEW, 1 ) = IWORK( JI )
+                        AB( JI, 2 ) = C( JI )
+                        NAB( JI, 2 ) = IWORK( JI )
+                     ELSE
+                        INFO = MMAX + 1
+                     END IF
+                  END IF
+   70          CONTINUE
+               IF( INFO.NE.0 )
+     $            RETURN
+               KL = KLNEW
+            ELSE
+*
+*              IJOB=3: Binary search.  Keep only the interval containing
+*                      w   s.t. N(w) = NVAL
+*
+               DO 80 JI = KF, KL
+                  IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
+                     AB( JI, 1 ) = C( JI )
+                     NAB( JI, 1 ) = IWORK( JI )
+                  END IF
+                  IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
+                     AB( JI, 2 ) = C( JI )
+                     NAB( JI, 2 ) = IWORK( JI )
+                  END IF
+   80          CONTINUE
+            END IF
+*
+         ELSE
+*
+*           End of Parallel Version of the loop
+*
+*           Begin of Serial Version of the loop
+*
+            KLNEW = KL
+            DO 100 JI = KF, KL
+*
+*              Compute N(w), the number of eigenvalues less than w
+*
+               TMP1 = C( JI )
+               TMP2 = D( 1 ) - TMP1
+               ITMP1 = 0
+               IF( TMP2.LE.PIVMIN ) THEN
+                  ITMP1 = 1
+                  TMP2 = MIN( TMP2, -PIVMIN )
+               END IF
+*
+*              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 90 J = 2, N
+                  TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
+                  IF( TMP2.LE.PIVMIN ) THEN
+                     ITMP1 = ITMP1 + 1
+                     TMP2 = MIN( TMP2, -PIVMIN )
+                  END IF
+   90          CONTINUE
+*
+               IF( IJOB.LE.2 ) THEN
+*
+*                 IJOB=2: Choose all intervals containing eigenvalues.
+*
+*                 Insure that N(w) is monotone
+*
+                  ITMP1 = MIN( NAB( JI, 2 ),
+     $                    MAX( NAB( JI, 1 ), ITMP1 ) )
+*
+*                 Update the Queue -- add intervals if both halves
+*                 contain eigenvalues.
+*
+                  IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
+*
+*                    No eigenvalue in the upper interval:
+*                    just use the lower interval.
+*
+                     AB( JI, 2 ) = TMP1
+*
+                  ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
+*
+*                    No eigenvalue in the lower interval:
+*                    just use the upper interval.
+*
+                     AB( JI, 1 ) = TMP1
+                  ELSE IF( KLNEW.LT.MMAX ) THEN
+*
+*                    Eigenvalue in both intervals -- add upper to queue.
+*
+                     KLNEW = KLNEW + 1
+                     AB( KLNEW, 2 ) = AB( JI, 2 )
+                     NAB( KLNEW, 2 ) = NAB( JI, 2 )
+                     AB( KLNEW, 1 ) = TMP1
+                     NAB( KLNEW, 1 ) = ITMP1
+                     AB( JI, 2 ) = TMP1
+                     NAB( JI, 2 ) = ITMP1
+                  ELSE
+                     INFO = MMAX + 1
+                     RETURN
+                  END IF
+               ELSE
+*
+*                 IJOB=3: Binary search.  Keep only the interval
+*                         containing  w  s.t. N(w) = NVAL
+*
+                  IF( ITMP1.LE.NVAL( JI ) ) THEN
+                     AB( JI, 1 ) = TMP1
+                     NAB( JI, 1 ) = ITMP1
+                  END IF
+                  IF( ITMP1.GE.NVAL( JI ) ) THEN
+                     AB( JI, 2 ) = TMP1
+                     NAB( JI, 2 ) = ITMP1
+                  END IF
+               END IF
+  100       CONTINUE
+            KL = KLNEW
+*
+*           End of Serial Version of the loop
+*
+         END IF
+*
+*        Check for convergence
+*
+         KFNEW = KF
+         DO 110 JI = KF, KL
+            TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
+            TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
+            IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
+     $          NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
+*
+*              Converged -- Swap with position KFNEW,
+*                           then increment KFNEW
+*
+               IF( JI.GT.KFNEW ) THEN
+                  TMP1 = AB( JI, 1 )
+                  TMP2 = AB( JI, 2 )
+                  ITMP1 = NAB( JI, 1 )
+                  ITMP2 = NAB( JI, 2 )
+                  AB( JI, 1 ) = AB( KFNEW, 1 )
+                  AB( JI, 2 ) = AB( KFNEW, 2 )
+                  NAB( JI, 1 ) = NAB( KFNEW, 1 )
+                  NAB( JI, 2 ) = NAB( KFNEW, 2 )
+                  AB( KFNEW, 1 ) = TMP1
+                  AB( KFNEW, 2 ) = TMP2
+                  NAB( KFNEW, 1 ) = ITMP1
+                  NAB( KFNEW, 2 ) = ITMP2
+                  IF( IJOB.EQ.3 ) THEN
+                     ITMP1 = NVAL( JI )
+                     NVAL( JI ) = NVAL( KFNEW )
+                     NVAL( KFNEW ) = ITMP1
+                  END IF
+               END IF
+               KFNEW = KFNEW + 1
+            END IF
+  110    CONTINUE
+         KF = KFNEW
+*
+*        Choose Midpoints
+*
+         DO 120 JI = KF, KL
+            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+  120    CONTINUE
+*
+*        If no more intervals to refine, quit.
+*
+         IF( KF.GT.KL )
+     $      GO TO 140
+  130 CONTINUE
+*
+*     Converged
+*
+  140 CONTINUE
+      INFO = MAX( KL+1-KF, 0 )
+      MOUT = KL
+*
+      RETURN
+*
+*     End of DLAEBZ
+*
+      END
diff --git a/SRC/dlaed0.f b/SRC/dlaed0.f
new file mode 100644
index 00000000..cf54722e
--- /dev/null
+++ b/SRC/dlaed0.f
@@ -0,0 +1,349 @@
+      SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED0 computes all eigenvalues and corresponding eigenvectors of a
+*  symmetric tridiagonal matrix using the divide and conquer method.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          = 0:  Compute eigenvalues only.
+*          = 1:  Compute eigenvectors of original dense symmetric matrix
+*                also.  On entry, Q contains the orthogonal matrix used
+*                to reduce the original matrix to tridiagonal form.
+*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
+*                matrix.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the orthogonal matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, the main diagonal of the tridiagonal matrix.
+*         On exit, its eigenvalues.
+*
+*  E      (input) DOUBLE PRECISION array, dimension (N-1)
+*         The off-diagonal elements of the tridiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+*         On entry, Q must contain an N-by-N orthogonal matrix.
+*         If ICOMPQ = 0    Q is not referenced.
+*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
+*                          orthogonal matrix used to reduce the full
+*                          matrix to tridiagonal form corresponding to
+*                          the subset of the full matrix which is being
+*                          decomposed at this time.
+*         If ICOMPQ = 2    On entry, Q will be the identity matrix.
+*                          On exit, Q contains the eigenvectors of the
+*                          tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  If eigenvectors are
+*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
+*
+*  QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)
+*         Referenced only when ICOMPQ = 1.  Used to store parts of
+*         the eigenvector matrix when the updating matrix multiplies
+*         take place.
+*
+*  LDQS   (input) INTEGER
+*         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
+*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
+*
+*  WORK   (workspace) DOUBLE PRECISION array,
+*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
+*                     1 + 3*N + 2*N*lg N + 2*N**2
+*                     ( lg( N ) = smallest integer k
+*                                 such that 2^k >= N )
+*         If ICOMPQ = 2, the dimension of WORK must be at least
+*                     4*N + N**2.
+*
+*  IWORK  (workspace) INTEGER array,
+*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
+*                        6 + 6*N + 5*N*lg N.
+*                        ( lg( N ) = smallest integer k
+*                                    such that 2^k >= N )
+*         If ICOMPQ = 2, the dimension of IWORK must be at least
+*                        3 + 5*N.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
+     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
+     $                   J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
+     $                   SPM2, SUBMAT, SUBPBS, TLVLS
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
+         INFO = -1
+      ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED0', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
+*
+*     Determine the size and placement of the submatrices, and save in
+*     the leading elements of IWORK.
+*
+      IWORK( 1 ) = N
+      SUBPBS = 1
+      TLVLS = 0
+   10 CONTINUE
+      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
+         DO 20 J = SUBPBS, 1, -1
+            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
+            IWORK( 2*J-1 ) = IWORK( J ) / 2
+   20    CONTINUE
+         TLVLS = TLVLS + 1
+         SUBPBS = 2*SUBPBS
+         GO TO 10
+      END IF
+      DO 30 J = 2, SUBPBS
+         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
+   30 CONTINUE
+*
+*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
+*     using rank-1 modifications (cuts).
+*
+      SPM1 = SUBPBS - 1
+      DO 40 I = 1, SPM1
+         SUBMAT = IWORK( I ) + 1
+         SMM1 = SUBMAT - 1
+         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
+         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
+   40 CONTINUE
+*
+      INDXQ = 4*N + 3
+      IF( ICOMPQ.NE.2 ) THEN
+*
+*        Set up workspaces for eigenvalues only/accumulate new vectors
+*        routine
+*
+         TEMP = LOG( DBLE( N ) ) / LOG( TWO )
+         LGN = INT( TEMP )
+         IF( 2**LGN.LT.N )
+     $      LGN = LGN + 1
+         IF( 2**LGN.LT.N )
+     $      LGN = LGN + 1
+         IPRMPT = INDXQ + N + 1
+         IPERM = IPRMPT + N*LGN
+         IQPTR = IPERM + N*LGN
+         IGIVPT = IQPTR + N + 2
+         IGIVCL = IGIVPT + N*LGN
+*
+         IGIVNM = 1
+         IQ = IGIVNM + 2*N*LGN
+         IWREM = IQ + N**2 + 1
+*
+*        Initialize pointers
+*
+         DO 50 I = 0, SUBPBS
+            IWORK( IPRMPT+I ) = 1
+            IWORK( IGIVPT+I ) = 1
+   50    CONTINUE
+         IWORK( IQPTR ) = 1
+      END IF
+*
+*     Solve each submatrix eigenproblem at the bottom of the divide and
+*     conquer tree.
+*
+      CURR = 0
+      DO 70 I = 0, SPM1
+         IF( I.EQ.0 ) THEN
+            SUBMAT = 1
+            MATSIZ = IWORK( 1 )
+         ELSE
+            SUBMAT = IWORK( I ) + 1
+            MATSIZ = IWORK( I+1 ) - IWORK( I )
+         END IF
+         IF( ICOMPQ.EQ.2 ) THEN
+            CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+     $                   Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 130
+         ELSE
+            CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+     $                   WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
+     $                   INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 130
+            IF( ICOMPQ.EQ.1 ) THEN
+               CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
+     $                     Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
+     $                     CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
+     $                     LDQS )
+            END IF
+            IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
+            CURR = CURR + 1
+         END IF
+         K = 1
+         DO 60 J = SUBMAT, IWORK( I+1 )
+            IWORK( INDXQ+J ) = K
+            K = K + 1
+   60    CONTINUE
+   70 CONTINUE
+*
+*     Successively merge eigensystems of adjacent submatrices
+*     into eigensystem for the corresponding larger matrix.
+*
+*     while ( SUBPBS > 1 )
+*
+      CURLVL = 1
+   80 CONTINUE
+      IF( SUBPBS.GT.1 ) THEN
+         SPM2 = SUBPBS - 2
+         DO 90 I = 0, SPM2, 2
+            IF( I.EQ.0 ) THEN
+               SUBMAT = 1
+               MATSIZ = IWORK( 2 )
+               MSD2 = IWORK( 1 )
+               CURPRB = 0
+            ELSE
+               SUBMAT = IWORK( I ) + 1
+               MATSIZ = IWORK( I+2 ) - IWORK( I )
+               MSD2 = MATSIZ / 2
+               CURPRB = CURPRB + 1
+            END IF
+*
+*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
+*     into an eigensystem of size MATSIZ.
+*     DLAED1 is used only for the full eigensystem of a tridiagonal
+*     matrix.
+*     DLAED7 handles the cases in which eigenvalues only or eigenvalues
+*     and eigenvectors of a full symmetric matrix (which was reduced to
+*     tridiagonal form) are desired.
+*
+            IF( ICOMPQ.EQ.2 ) THEN
+               CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
+     $                      LDQ, IWORK( INDXQ+SUBMAT ),
+     $                      E( SUBMAT+MSD2-1 ), MSD2, WORK,
+     $                      IWORK( SUBPBS+1 ), INFO )
+            ELSE
+               CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
+     $                      D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
+     $                      IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
+     $                      MSD2, WORK( IQ ), IWORK( IQPTR ),
+     $                      IWORK( IPRMPT ), IWORK( IPERM ),
+     $                      IWORK( IGIVPT ), IWORK( IGIVCL ),
+     $                      WORK( IGIVNM ), WORK( IWREM ),
+     $                      IWORK( SUBPBS+1 ), INFO )
+            END IF
+            IF( INFO.NE.0 )
+     $         GO TO 130
+            IWORK( I / 2+1 ) = IWORK( I+2 )
+   90    CONTINUE
+         SUBPBS = SUBPBS / 2
+         CURLVL = CURLVL + 1
+         GO TO 80
+      END IF
+*
+*     end while
+*
+*     Re-merge the eigenvalues/vectors which were deflated at the final
+*     merge step.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         DO 100 I = 1, N
+            J = IWORK( INDXQ+I )
+            WORK( I ) = D( J )
+            CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
+  100    CONTINUE
+         CALL DCOPY( N, WORK, 1, D, 1 )
+      ELSE IF( ICOMPQ.EQ.2 ) THEN
+         DO 110 I = 1, N
+            J = IWORK( INDXQ+I )
+            WORK( I ) = D( J )
+            CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
+  110    CONTINUE
+         CALL DCOPY( N, WORK, 1, D, 1 )
+         CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
+      ELSE
+         DO 120 I = 1, N
+            J = IWORK( INDXQ+I )
+            WORK( I ) = D( J )
+  120    CONTINUE
+         CALL DCOPY( N, WORK, 1, D, 1 )
+      END IF
+      GO TO 140
+*
+  130 CONTINUE
+      INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+*
+  140 CONTINUE
+      RETURN
+*
+*     End of DLAED0
+*
+      END
diff --git a/SRC/dlaed1.f b/SRC/dlaed1.f
new file mode 100644
index 00000000..f9718bbe
--- /dev/null
+++ b/SRC/dlaed1.f
@@ -0,0 +1,195 @@
+      SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CUTPNT, INFO, LDQ, N
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            INDXQ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED1 computes the updated eigensystem of a diagonal
+*  matrix after modification by a rank-one symmetric matrix.  This
+*  routine is used only for the eigenproblem which requires all
+*  eigenvalues and eigenvectors of a tridiagonal matrix.  DLAED7 handles
+*  the case in which eigenvalues only or eigenvalues and eigenvectors
+*  of a full symmetric matrix (which was reduced to tridiagonal form)
+*  are desired.
+*
+*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+*     where Z = Q'u, u is a vector of length N with ones in the
+*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+*     The eigenvectors of the original matrix are stored in Q, and the
+*     eigenvalues are in D.  The algorithm consists of three stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple eigenvalues or if there is a zero in
+*        the Z vector.  For each such occurence the dimension of the
+*        secular equation problem is reduced by one.  This stage is
+*        performed by the routine DLAED2.
+*
+*        The second stage consists of calculating the updated
+*        eigenvalues. This is done by finding the roots of the secular
+*        equation via the routine DLAED4 (as called by DLAED3).
+*        This routine also calculates the eigenvectors of the current
+*        problem.
+*
+*        The final stage consists of computing the updated eigenvectors
+*        directly using the updated eigenvalues.  The eigenvectors for
+*        the current problem are multiplied with the eigenvectors from
+*        the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, the eigenvalues of the rank-1-perturbed matrix.
+*         On exit, the eigenvalues of the repaired matrix.
+*
+*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*         On entry, the eigenvectors of the rank-1-perturbed matrix.
+*         On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (input/output) INTEGER array, dimension (N)
+*         On entry, the permutation which separately sorts the two
+*         subproblems in D into ascending order.
+*         On exit, the permutation which will reintegrate the
+*         subproblems back into sorted order,
+*         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  RHO    (input) DOUBLE PRECISION
+*         The subdiagonal entry used to create the rank-1 modification.
+*
+*  CUTPNT (input) INTEGER
+*         The location of the last eigenvalue in the leading sub-matrix.
+*         min(1,N) <= CUTPNT <= N/2.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
+     $                   IW, IZ, K, N1, N2, ZPP1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED1', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     The following values are integer pointers which indicate
+*     the portion of the workspace
+*     used by a particular array in DLAED2 and DLAED3.
+*
+      IZ = 1
+      IDLMDA = IZ + N
+      IW = IDLMDA + N
+      IQ2 = IW + N
+*
+      INDX = 1
+      INDXC = INDX + N
+      COLTYP = INDXC + N
+      INDXP = COLTYP + N
+*
+*
+*     Form the z-vector which consists of the last row of Q_1 and the
+*     first row of Q_2.
+*
+      CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
+      ZPP1 = CUTPNT + 1
+      CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
+*
+*     Deflate eigenvalues.
+*
+      CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
+     $             WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
+     $             IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
+     $             IWORK( COLTYP ), INFO )
+*
+      IF( INFO.NE.0 )
+     $   GO TO 20
+*
+*     Solve Secular Equation.
+*
+      IF( K.NE.0 ) THEN
+         IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
+     $        ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
+         CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
+     $                WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
+     $                WORK( IW ), WORK( IS ), INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 20
+*
+*     Prepare the INDXQ sorting permutation.
+*
+         N1 = K
+         N2 = N - K
+         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
+      ELSE
+         DO 10 I = 1, N
+            INDXQ( I ) = I
+   10    CONTINUE
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DLAED1
+*
+      END
diff --git a/SRC/dlaed2.f b/SRC/dlaed2.f
new file mode 100644
index 00000000..1b0ecfe9
--- /dev/null
+++ b/SRC/dlaed2.f
@@ -0,0 +1,434 @@
+      SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
+     $                   Q2, INDX, INDXC, INDXP, COLTYP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDQ, N, N1
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
+     $                   INDXQ( * )
+      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+     $                   W( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED2 merges the two sets of eigenvalues together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  eigenvalues are close together or if there is a tiny entry in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  Arguments
+*  =========
+*
+*  K      (output) INTEGER
+*         The number of non-deflated eigenvalues, and the order of the
+*         related secular equation. 0 <= K <=N.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  N1     (input) INTEGER
+*         The location of the last eigenvalue in the leading sub-matrix.
+*         min(1,N) <= N1 <= N/2.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, D contains the eigenvalues of the two submatrices to
+*         be combined.
+*         On exit, D contains the trailing (N-K) updated eigenvalues
+*         (those which were deflated) sorted into increasing order.
+*
+*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+*         On entry, Q contains the eigenvectors of two submatrices in
+*         the two square blocks with corners at (1,1), (N1,N1)
+*         and (N1+1, N1+1), (N,N).
+*         On exit, Q contains the trailing (N-K) updated eigenvectors
+*         (those which were deflated) in its last N-K columns.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (input/output) INTEGER array, dimension (N)
+*         The permutation which separately sorts the two sub-problems
+*         in D into ascending order.  Note that elements in the second
+*         half of this permutation must first have N1 added to their
+*         values. Destroyed on exit.
+*
+*  RHO    (input/output) DOUBLE PRECISION
+*         On entry, the off-diagonal element associated with the rank-1
+*         cut which originally split the two submatrices which are now
+*         being recombined.
+*         On exit, RHO has been modified to the value required by
+*         DLAED3.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension (N)
+*         On entry, Z contains the updating vector (the last
+*         row of the first sub-eigenvector matrix and the first row of
+*         the second sub-eigenvector matrix).
+*         On exit, the contents of Z have been destroyed by the updating
+*         process.
+*
+*  DLAMDA (output) DOUBLE PRECISION array, dimension (N)
+*         A copy of the first K eigenvalues which will be used by
+*         DLAED3 to form the secular equation.
+*
+*  W      (output) DOUBLE PRECISION array, dimension (N)
+*         The first k values of the final deflation-altered z-vector
+*         which will be passed to DLAED3.
+*
+*  Q2     (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
+*         A copy of the first K eigenvectors which will be used by
+*         DLAED3 in a matrix multiply (DGEMM) to solve for the new
+*         eigenvectors.
+*
+*  INDX   (workspace) INTEGER array, dimension (N)
+*         The permutation used to sort the contents of DLAMDA into
+*         ascending order.
+*
+*  INDXC  (output) INTEGER array, dimension (N)
+*         The permutation used to arrange the columns of the deflated
+*         Q matrix into three groups:  the first group contains non-zero
+*         elements only at and above N1, the second contains
+*         non-zero elements only below N1, and the third is dense.
+*
+*  INDXP  (workspace) INTEGER array, dimension (N)
+*         The permutation used to place deflated values of D at the end
+*         of the array.  INDXP(1:K) points to the nondeflated D-values
+*         and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+*  COLTYP (workspace/output) INTEGER array, dimension (N)
+*         During execution, a label which will indicate which of the
+*         following types a column in the Q2 matrix is:
+*         1 : non-zero in the upper half only;
+*         2 : dense;
+*         3 : non-zero in the lower half only;
+*         4 : deflated.
+*         On exit, COLTYP(i) is the number of columns of type i,
+*         for i=1 to 4 only.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
+     $                   TWO = 2.0D0, EIGHT = 8.0D0 )
+*     ..
+*     .. Local Arrays ..
+      INTEGER            CTOT( 4 ), PSM( 4 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
+     $                   N2, NJ, PJ
+      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           IDAMAX, DLAMCH, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      N2 = N - N1
+      N1P1 = N1 + 1
+*
+      IF( RHO.LT.ZERO ) THEN
+         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
+      END IF
+*
+*     Normalize z so that norm(z) = 1.  Since z is the concatenation of
+*     two normalized vectors, norm2(z) = sqrt(2).
+*
+      T = ONE / SQRT( TWO )
+      CALL DSCAL( N, T, Z, 1 )
+*
+*     RHO = ABS( norm(z)**2 * RHO )
+*
+      RHO = ABS( TWO*RHO )
+*
+*     Sort the eigenvalues into increasing order
+*
+      DO 10 I = N1P1, N
+         INDXQ( I ) = INDXQ( I ) + N1
+   10 CONTINUE
+*
+*     re-integrate the deflated parts from the last pass
+*
+      DO 20 I = 1, N
+         DLAMDA( I ) = D( INDXQ( I ) )
+   20 CONTINUE
+      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
+      DO 30 I = 1, N
+         INDX( I ) = INDXQ( INDXC( I ) )
+   30 CONTINUE
+*
+*     Calculate the allowable deflation tolerance
+*
+      IMAX = IDAMAX( N, Z, 1 )
+      JMAX = IDAMAX( N, D, 1 )
+      EPS = DLAMCH( 'Epsilon' )
+      TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
+*
+*     If the rank-1 modifier is small enough, no more needs to be done
+*     except to reorganize Q so that its columns correspond with the
+*     elements in D.
+*
+      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+         K = 0
+         IQ2 = 1
+         DO 40 J = 1, N
+            I = INDX( J )
+            CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
+            DLAMDA( J ) = D( I )
+            IQ2 = IQ2 + N
+   40    CONTINUE
+         CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
+         CALL DCOPY( N, DLAMDA, 1, D, 1 )
+         GO TO 190
+      END IF
+*
+*     If there are multiple eigenvalues then the problem deflates.  Here
+*     the number of equal eigenvalues are found.  As each equal
+*     eigenvalue is found, an elementary reflector is computed to rotate
+*     the corresponding eigensubspace so that the corresponding
+*     components of Z are zero in this new basis.
+*
+      DO 50 I = 1, N1
+         COLTYP( I ) = 1
+   50 CONTINUE
+      DO 60 I = N1P1, N
+         COLTYP( I ) = 3
+   60 CONTINUE
+*
+*
+      K = 0
+      K2 = N + 1
+      DO 70 J = 1, N
+         NJ = INDX( J )
+         IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            COLTYP( NJ ) = 4
+            INDXP( K2 ) = NJ
+            IF( J.EQ.N )
+     $         GO TO 100
+         ELSE
+            PJ = NJ
+            GO TO 80
+         END IF
+   70 CONTINUE
+   80 CONTINUE
+      J = J + 1
+      NJ = INDX( J )
+      IF( J.GT.N )
+     $   GO TO 100
+      IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         COLTYP( NJ ) = 4
+         INDXP( K2 ) = NJ
+      ELSE
+*
+*        Check if eigenvalues are close enough to allow deflation.
+*
+         S = Z( PJ )
+         C = Z( NJ )
+*
+*        Find sqrt(a**2+b**2) without overflow or
+*        destructive underflow.
+*
+         TAU = DLAPY2( C, S )
+         T = D( NJ ) - D( PJ )
+         C = C / TAU
+         S = -S / TAU
+         IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            Z( NJ ) = TAU
+            Z( PJ ) = ZERO
+            IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
+     $         COLTYP( NJ ) = 2
+            COLTYP( PJ ) = 4
+            CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
+            T = D( PJ )*C**2 + D( NJ )*S**2
+            D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
+            D( PJ ) = T
+            K2 = K2 - 1
+            I = 1
+   90       CONTINUE
+            IF( K2+I.LE.N ) THEN
+               IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
+                  INDXP( K2+I-1 ) = INDXP( K2+I )
+                  INDXP( K2+I ) = PJ
+                  I = I + 1
+                  GO TO 90
+               ELSE
+                  INDXP( K2+I-1 ) = PJ
+               END IF
+            ELSE
+               INDXP( K2+I-1 ) = PJ
+            END IF
+            PJ = NJ
+         ELSE
+            K = K + 1
+            DLAMDA( K ) = D( PJ )
+            W( K ) = Z( PJ )
+            INDXP( K ) = PJ
+            PJ = NJ
+         END IF
+      END IF
+      GO TO 80
+  100 CONTINUE
+*
+*     Record the last eigenvalue.
+*
+      K = K + 1
+      DLAMDA( K ) = D( PJ )
+      W( K ) = Z( PJ )
+      INDXP( K ) = PJ
+*
+*     Count up the total number of the various types of columns, then
+*     form a permutation which positions the four column types into
+*     four uniform groups (although one or more of these groups may be
+*     empty).
+*
+      DO 110 J = 1, 4
+         CTOT( J ) = 0
+  110 CONTINUE
+      DO 120 J = 1, N
+         CT = COLTYP( J )
+         CTOT( CT ) = CTOT( CT ) + 1
+  120 CONTINUE
+*
+*     PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+      PSM( 1 ) = 1
+      PSM( 2 ) = 1 + CTOT( 1 )
+      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+      K = N - CTOT( 4 )
+*
+*     Fill out the INDXC array so that the permutation which it induces
+*     will place all type-1 columns first, all type-2 columns next,
+*     then all type-3's, and finally all type-4's.
+*
+      DO 130 J = 1, N
+         JS = INDXP( J )
+         CT = COLTYP( JS )
+         INDX( PSM( CT ) ) = JS
+         INDXC( PSM( CT ) ) = J
+         PSM( CT ) = PSM( CT ) + 1
+  130 CONTINUE
+*
+*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+*     and Q2 respectively.  The eigenvalues/vectors which were not
+*     deflated go into the first K slots of DLAMDA and Q2 respectively,
+*     while those which were deflated go into the last N - K slots.
+*
+      I = 1
+      IQ1 = 1
+      IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
+      DO 140 J = 1, CTOT( 1 )
+         JS = INDX( I )
+         CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+         Z( I ) = D( JS )
+         I = I + 1
+         IQ1 = IQ1 + N1
+  140 CONTINUE
+*
+      DO 150 J = 1, CTOT( 2 )
+         JS = INDX( I )
+         CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+         CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+         Z( I ) = D( JS )
+         I = I + 1
+         IQ1 = IQ1 + N1
+         IQ2 = IQ2 + N2
+  150 CONTINUE
+*
+      DO 160 J = 1, CTOT( 3 )
+         JS = INDX( I )
+         CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+         Z( I ) = D( JS )
+         I = I + 1
+         IQ2 = IQ2 + N2
+  160 CONTINUE
+*
+      IQ1 = IQ2
+      DO 170 J = 1, CTOT( 4 )
+         JS = INDX( I )
+         CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
+         IQ2 = IQ2 + N
+         Z( I ) = D( JS )
+         I = I + 1
+  170 CONTINUE
+*
+*     The deflated eigenvalues and their corresponding vectors go back
+*     into the last N - K slots of D and Q respectively.
+*
+      CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
+      CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
+*
+*     Copy CTOT into COLTYP for referencing in DLAED3.
+*
+      DO 180 J = 1, 4
+         COLTYP( J ) = CTOT( J )
+  180 CONTINUE
+*
+  190 CONTINUE
+      RETURN
+*
+*     End of DLAED2
+*
+      END
diff --git a/SRC/dlaed3.f b/SRC/dlaed3.f
new file mode 100644
index 00000000..b6846018
--- /dev/null
+++ b/SRC/dlaed3.f
@@ -0,0 +1,264 @@
+      SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
+     $                   CTOT, W, S, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDQ, N, N1
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            CTOT( * ), INDX( * )
+      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+     $                   S( * ), W( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED3 finds the roots of the secular equation, as defined by the
+*  values in D, W, and RHO, between 1 and K.  It makes the
+*  appropriate calls to DLAED4 and then updates the eigenvectors by
+*  multiplying the matrix of eigenvectors of the pair of eigensystems
+*  being combined by the matrix of eigenvectors of the K-by-K system
+*  which is solved here.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  K       (input) INTEGER
+*          The number of terms in the rational function to be solved by
+*          DLAED4.  K >= 0.
+*
+*  N       (input) INTEGER
+*          The number of rows and columns in the Q matrix.
+*          N >= K (deflation may result in N>K).
+*
+*  N1      (input) INTEGER
+*          The location of the last eigenvalue in the leading submatrix.
+*          min(1,N) <= N1 <= N/2.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          D(I) contains the updated eigenvalues for
+*          1 <= I <= K.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          Initially the first K columns are used as workspace.
+*          On output the columns 1 to K contain
+*          the updated eigenvectors.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  RHO     (input) DOUBLE PRECISION
+*          The value of the parameter in the rank one update equation.
+*          RHO >= 0 required.
+*
+*  DLAMDA  (input/output) DOUBLE PRECISION array, dimension (K)
+*          The first K elements of this array contain the old roots
+*          of the deflated updating problem.  These are the poles
+*          of the secular equation. May be changed on output by
+*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
+*          Cray-2, or Cray C-90, as described above.
+*
+*  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N)
+*          The first K columns of this matrix contain the non-deflated
+*          eigenvectors for the split problem.
+*
+*  INDX    (input) INTEGER array, dimension (N)
+*          The permutation used to arrange the columns of the deflated
+*          Q matrix into three groups (see DLAED2).
+*          The rows of the eigenvectors found by DLAED4 must be likewise
+*          permuted before the matrix multiply can take place.
+*
+*  CTOT    (input) INTEGER array, dimension (4)
+*          A count of the total number of the various types of columns
+*          in Q, as described in INDX.  The fourth column type is any
+*          column which has been deflated.
+*
+*  W       (input/output) DOUBLE PRECISION array, dimension (K)
+*          The first K elements of this array contain the components
+*          of the deflation-adjusted updating vector. Destroyed on
+*          output.
+*
+*  S       (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
+*          Will contain the eigenvectors of the repaired matrix which
+*          will be multiplied by the previously accumulated eigenvectors
+*          to update the system.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of S.  LDS >= max(1,K).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, IQ2, J, N12, N2, N23
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3, DNRM2
+      EXTERNAL           DLAMC3, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( K.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.K ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED3', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 )
+     $   RETURN
+*
+*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DLAMDA(I) if it is 1; this makes the subsequent
+*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DLAMDA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DLAMDA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 10 I = 1, K
+         DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+   10 CONTINUE
+*
+      DO 20 J = 1, K
+         CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+*        If the zero finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 )
+     $      GO TO 120
+   20 CONTINUE
+*
+      IF( K.EQ.1 )
+     $   GO TO 110
+      IF( K.EQ.2 ) THEN
+         DO 30 J = 1, K
+            W( 1 ) = Q( 1, J )
+            W( 2 ) = Q( 2, J )
+            II = INDX( 1 )
+            Q( 1, J ) = W( II )
+            II = INDX( 2 )
+            Q( 2, J ) = W( II )
+   30    CONTINUE
+         GO TO 110
+      END IF
+*
+*     Compute updated W.
+*
+      CALL DCOPY( K, W, 1, S, 1 )
+*
+*     Initialize W(I) = Q(I,I)
+*
+      CALL DCOPY( K, Q, LDQ+1, W, 1 )
+      DO 60 J = 1, K
+         DO 40 I = 1, J - 1
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   40    CONTINUE
+         DO 50 I = J + 1, K
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   50    CONTINUE
+   60 CONTINUE
+      DO 70 I = 1, K
+         W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
+   70 CONTINUE
+*
+*     Compute eigenvectors of the modified rank-1 modification.
+*
+      DO 100 J = 1, K
+         DO 80 I = 1, K
+            S( I ) = W( I ) / Q( I, J )
+   80    CONTINUE
+         TEMP = DNRM2( K, S, 1 )
+         DO 90 I = 1, K
+            II = INDX( I )
+            Q( I, J ) = S( II ) / TEMP
+   90    CONTINUE
+  100 CONTINUE
+*
+*     Compute the updated eigenvectors.
+*
+  110 CONTINUE
+*
+      N2 = N - N1
+      N12 = CTOT( 1 ) + CTOT( 2 )
+      N23 = CTOT( 2 ) + CTOT( 3 )
+*
+      CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
+      IQ2 = N1*N12 + 1
+      IF( N23.NE.0 ) THEN
+         CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
+     $               ZERO, Q( N1+1, 1 ), LDQ )
+      ELSE
+         CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
+      END IF
+*
+      CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
+      IF( N12.NE.0 ) THEN
+         CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
+     $               LDQ )
+      ELSE
+         CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
+      END IF
+*
+*
+  120 CONTINUE
+      RETURN
+*
+*     End of DLAED3
+*
+      END
diff --git a/SRC/dlaed4.f b/SRC/dlaed4.f
new file mode 100644
index 00000000..ef3238e2
--- /dev/null
+++ b/SRC/dlaed4.f
@@ -0,0 +1,844 @@
+      SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I, INFO, N
+      DOUBLE PRECISION   DLAM, RHO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), DELTA( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the I-th updated eigenvalue of a symmetric
+*  rank-one modification to a diagonal matrix whose elements are
+*  given in the array d, and that
+*
+*             D(i) < D(j)  for  i < j
+*
+*  and that RHO > 0.  This is arranged by the calling routine, and is
+*  no loss in generality.  The rank-one modified system is thus
+*
+*             diag( D )  +  RHO *  Z * Z_transpose.
+*
+*  where we assume the Euclidean norm of Z is 1.
+*
+*  The method consists of approximating the rational functions in the
+*  secular equation by simpler interpolating rational functions.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The length of all arrays.
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  1 <= I <= N.
+*
+*  D      (input) DOUBLE PRECISION array, dimension (N)
+*         The original eigenvalues.  It is assumed that they are in
+*         order, D(I) < D(J)  for I < J.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension (N)
+*         The components of the updating vector.
+*
+*  DELTA  (output) DOUBLE PRECISION array, dimension (N)
+*         If N .GT. 2, DELTA contains (D(j) - lambda_I) in its  j-th
+*         component.  If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5
+*         for detail. The vector DELTA contains the information necessary
+*         to construct the eigenvectors by DLAED3 and DLAED9.
+*
+*  RHO    (input) DOUBLE PRECISION
+*         The scalar in the symmetric updating formula.
+*
+*  DLAM   (output) DOUBLE PRECISION
+*         The computed lambda_I, the I-th updated eigenvalue.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit
+*         > 0:  if INFO = 1, the updating process failed.
+*
+*  Internal Parameters
+*  ===================
+*
+*  Logical variable ORGATI (origin-at-i?) is used for distinguishing
+*  whether D(i) or D(i+1) is treated as the origin.
+*
+*            ORGATI = .true.    origin at i
+*            ORGATI = .false.   origin at i+1
+*
+*   Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+*   if we are working with THREE poles!
+*
+*   MAXIT is the maximum number of iterations allowed for each
+*   eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 30 )
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
+     $                   TEN = 10.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ORGATI, SWTCH, SWTCH3
+      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
+      DOUBLE PRECISION   A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
+     $                   EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
+     $                   RHOINV, TAU, TEMP, TEMP1, W
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   ZZ( 3 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAED5, DLAED6
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Since this routine is called in an inner loop, we do no argument
+*     checking.
+*
+*     Quick return for N=1 and 2.
+*
+      INFO = 0
+      IF( N.EQ.1 ) THEN
+*
+*         Presumably, I=1 upon entry
+*
+         DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
+         DELTA( 1 ) = ONE
+         RETURN
+      END IF
+      IF( N.EQ.2 ) THEN
+         CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
+         RETURN
+      END IF
+*
+*     Compute machine epsilon
+*
+      EPS = DLAMCH( 'Epsilon' )
+      RHOINV = ONE / RHO
+*
+*     The case I = N
+*
+      IF( I.EQ.N ) THEN
+*
+*        Initialize some basic variables
+*
+         II = N - 1
+         NITER = 1
+*
+*        Calculate initial guess
+*
+         MIDPT = RHO / TWO
+*
+*        If ||Z||_2 is not one, then TEMP should be set to
+*        RHO * ||Z||_2^2 / TWO
+*
+         DO 10 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+   10    CONTINUE
+*
+         PSI = ZERO
+         DO 20 J = 1, N - 2
+            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+   20    CONTINUE
+*
+         C = RHOINV + PSI
+         W = C + Z( II )*Z( II ) / DELTA( II ) +
+     $       Z( N )*Z( N ) / DELTA( N )
+*
+         IF( W.LE.ZERO ) THEN
+            TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
+     $             Z( N )*Z( N ) / RHO
+            IF( C.LE.TEMP ) THEN
+               TAU = RHO
+            ELSE
+               DEL = D( N ) - D( N-1 )
+               A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+               B = Z( N )*Z( N )*DEL
+               IF( A.LT.ZERO ) THEN
+                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+               ELSE
+                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+               END IF
+            END IF
+*
+*           It can be proved that
+*               D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
+*
+            DLTLB = MIDPT
+            DLTUB = RHO
+         ELSE
+            DEL = D( N ) - D( N-1 )
+            A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+            B = Z( N )*Z( N )*DEL
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+            ELSE
+               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+            END IF
+*
+*           It can be proved that
+*               D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
+*
+            DLTLB = ZERO
+            DLTUB = MIDPT
+         END IF
+*
+         DO 30 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - TAU
+   30    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 40 J = 1, II
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   40    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / DELTA( N )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            DLAM = D( I ) + TAU
+            GO TO 250
+         END IF
+*
+         IF( W.LE.ZERO ) THEN
+            DLTLB = MAX( DLTLB, TAU )
+         ELSE
+            DLTUB = MIN( DLTUB, TAU )
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+         A = ( DELTA( N-1 )+DELTA( N ) )*W -
+     $       DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+         B = DELTA( N-1 )*DELTA( N )*W
+         IF( C.LT.ZERO )
+     $      C = ABS( C )
+         IF( C.EQ.ZERO ) THEN
+*          ETA = B/A
+*           ETA = RHO - TAU
+            ETA = DLTUB - TAU
+         ELSE IF( A.GE.ZERO ) THEN
+            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GT.ZERO )
+     $      ETA = -W / ( DPSI+DPHI )
+         TEMP = TAU + ETA
+         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+            IF( W.LT.ZERO ) THEN
+               ETA = ( DLTUB-TAU ) / TWO
+            ELSE
+               ETA = ( DLTLB-TAU ) / TWO
+            END IF
+         END IF
+         DO 50 J = 1, N
+            DELTA( J ) = DELTA( J ) - ETA
+   50    CONTINUE
+*
+         TAU = TAU + ETA
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 60 J = 1, II
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   60    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / DELTA( N )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Main loop to update the values of the array   DELTA
+*
+         ITER = NITER + 1
+*
+         DO 90 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               DLAM = D( I ) + TAU
+               GO TO 250
+            END IF
+*
+            IF( W.LE.ZERO ) THEN
+               DLTLB = MAX( DLTLB, TAU )
+            ELSE
+               DLTUB = MIN( DLTUB, TAU )
+            END IF
+*
+*           Calculate the new step
+*
+            C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+            A = ( DELTA( N-1 )+DELTA( N ) )*W -
+     $          DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+            B = DELTA( N-1 )*DELTA( N )*W
+            IF( A.GE.ZERO ) THEN
+               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GT.ZERO )
+     $         ETA = -W / ( DPSI+DPHI )
+            TEMP = TAU + ETA
+            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+               IF( W.LT.ZERO ) THEN
+                  ETA = ( DLTUB-TAU ) / TWO
+               ELSE
+                  ETA = ( DLTLB-TAU ) / TWO
+               END IF
+            END IF
+            DO 70 J = 1, N
+               DELTA( J ) = DELTA( J ) - ETA
+   70       CONTINUE
+*
+            TAU = TAU + ETA
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 80 J = 1, II
+               TEMP = Z( J ) / DELTA( J )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+   80       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            TEMP = Z( N ) / DELTA( N )
+            PHI = Z( N )*TEMP
+            DPHI = TEMP*TEMP
+            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $               ABS( TAU )*( DPSI+DPHI )
+*
+            W = RHOINV + PHI + PSI
+   90    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+         DLAM = D( I ) + TAU
+         GO TO 250
+*
+*        End for the case I = N
+*
+      ELSE
+*
+*        The case for I < N
+*
+         NITER = 1
+         IP1 = I + 1
+*
+*        Calculate initial guess
+*
+         DEL = D( IP1 ) - D( I )
+         MIDPT = DEL / TWO
+         DO 100 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+  100    CONTINUE
+*
+         PSI = ZERO
+         DO 110 J = 1, I - 1
+            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+  110    CONTINUE
+*
+         PHI = ZERO
+         DO 120 J = N, I + 2, -1
+            PHI = PHI + Z( J )*Z( J ) / DELTA( J )
+  120    CONTINUE
+         C = RHOINV + PSI + PHI
+         W = C + Z( I )*Z( I ) / DELTA( I ) +
+     $       Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
+*
+         IF( W.GT.ZERO ) THEN
+*
+*           d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
+*
+*           We choose d(i) as origin.
+*
+            ORGATI = .TRUE.
+            A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+            B = Z( I )*Z( I )*DEL
+            IF( A.GT.ZERO ) THEN
+               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            ELSE
+               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+            DLTLB = ZERO
+            DLTUB = MIDPT
+         ELSE
+*
+*           (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
+*
+*           We choose d(i+1) as origin.
+*
+            ORGATI = .FALSE.
+            A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+            B = Z( IP1 )*Z( IP1 )*DEL
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+            ELSE
+               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+            DLTLB = -MIDPT
+            DLTUB = ZERO
+         END IF
+*
+         IF( ORGATI ) THEN
+            DO 130 J = 1, N
+               DELTA( J ) = ( D( J )-D( I ) ) - TAU
+  130       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
+  140       CONTINUE
+         END IF
+         IF( ORGATI ) THEN
+            II = I
+         ELSE
+            II = I + 1
+         END IF
+         IIM1 = II - 1
+         IIP1 = II + 1
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 150 J = 1, IIM1
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  150    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 160 J = N, IIP1, -1
+            TEMP = Z( J ) / DELTA( J )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  160    CONTINUE
+*
+         W = RHOINV + PHI + PSI
+*
+*        W is the value of the secular function with
+*        its ii-th element removed.
+*
+         SWTCH3 = .FALSE.
+         IF( ORGATI ) THEN
+            IF( W.LT.ZERO )
+     $         SWTCH3 = .TRUE.
+         ELSE
+            IF( W.GT.ZERO )
+     $         SWTCH3 = .TRUE.
+         END IF
+         IF( II.EQ.1 .OR. II.EQ.N )
+     $      SWTCH3 = .FALSE.
+*
+         TEMP = Z( II ) / DELTA( II )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = W + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            IF( ORGATI ) THEN
+               DLAM = D( I ) + TAU
+            ELSE
+               DLAM = D( IP1 ) + TAU
+            END IF
+            GO TO 250
+         END IF
+*
+         IF( W.LE.ZERO ) THEN
+            DLTLB = MAX( DLTLB, TAU )
+         ELSE
+            DLTUB = MIN( DLTUB, TAU )
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         IF( .NOT.SWTCH3 ) THEN
+            IF( ORGATI ) THEN
+               C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
+     $             ( Z( I ) / DELTA( I ) )**2
+            ELSE
+               C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+     $             ( Z( IP1 ) / DELTA( IP1 ) )**2
+            END IF
+            A = ( DELTA( I )+DELTA( IP1 ) )*W -
+     $          DELTA( I )*DELTA( IP1 )*DW
+            B = DELTA( I )*DELTA( IP1 )*W
+            IF( C.EQ.ZERO ) THEN
+               IF( A.EQ.ZERO ) THEN
+                  IF( ORGATI ) THEN
+                     A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
+     $                   ( DPSI+DPHI )
+                  ELSE
+                     A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
+     $                   ( DPSI+DPHI )
+                  END IF
+               END IF
+               ETA = B / A
+            ELSE IF( A.LE.ZERO ) THEN
+               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+         ELSE
+*
+*           Interpolation using THREE most relevant poles
+*
+            TEMP = RHOINV + PSI + PHI
+            IF( ORGATI ) THEN
+               TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+               TEMP1 = TEMP1*TEMP1
+               C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+     $             ( D( IIM1 )-D( IIP1 ) )*TEMP1
+               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+               ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+     $                   ( ( DPSI-TEMP1 )+DPHI )
+            ELSE
+               TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+               TEMP1 = TEMP1*TEMP1
+               C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+     $             ( D( IIP1 )-D( IIM1 ) )*TEMP1
+               ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+     $                   ( DPSI+( DPHI-TEMP1 ) )
+               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+            END IF
+            ZZ( 2 ) = Z( II )*Z( II )
+            CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+     $                   INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 250
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GE.ZERO )
+     $      ETA = -W / DW
+         TEMP = TAU + ETA
+         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+            IF( W.LT.ZERO ) THEN
+               ETA = ( DLTUB-TAU ) / TWO
+            ELSE
+               ETA = ( DLTLB-TAU ) / TWO
+            END IF
+         END IF
+*
+         PREW = W
+*
+         DO 180 J = 1, N
+            DELTA( J ) = DELTA( J ) - ETA
+  180    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 190 J = 1, IIM1
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  190    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 200 J = N, IIP1, -1
+            TEMP = Z( J ) / DELTA( J )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  200    CONTINUE
+*
+         TEMP = Z( II ) / DELTA( II )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = RHOINV + PHI + PSI + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
+*
+         SWTCH = .FALSE.
+         IF( ORGATI ) THEN
+            IF( -W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         ELSE
+            IF( W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         END IF
+*
+         TAU = TAU + ETA
+*
+*        Main loop to update the values of the array   DELTA
+*
+         ITER = NITER + 1
+*
+         DO 240 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               IF( ORGATI ) THEN
+                  DLAM = D( I ) + TAU
+               ELSE
+                  DLAM = D( IP1 ) + TAU
+               END IF
+               GO TO 250
+            END IF
+*
+            IF( W.LE.ZERO ) THEN
+               DLTLB = MAX( DLTLB, TAU )
+            ELSE
+               DLTUB = MIN( DLTUB, TAU )
+            END IF
+*
+*           Calculate the new step
+*
+            IF( .NOT.SWTCH3 ) THEN
+               IF( .NOT.SWTCH ) THEN
+                  IF( ORGATI ) THEN
+                     C = W - DELTA( IP1 )*DW -
+     $                   ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
+                  ELSE
+                     C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+     $                   ( Z( IP1 ) / DELTA( IP1 ) )**2
+                  END IF
+               ELSE
+                  TEMP = Z( II ) / DELTA( II )
+                  IF( ORGATI ) THEN
+                     DPSI = DPSI + TEMP*TEMP
+                  ELSE
+                     DPHI = DPHI + TEMP*TEMP
+                  END IF
+                  C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
+               END IF
+               A = ( DELTA( I )+DELTA( IP1 ) )*W -
+     $             DELTA( I )*DELTA( IP1 )*DW
+               B = DELTA( I )*DELTA( IP1 )*W
+               IF( C.EQ.ZERO ) THEN
+                  IF( A.EQ.ZERO ) THEN
+                     IF( .NOT.SWTCH ) THEN
+                        IF( ORGATI ) THEN
+                           A = Z( I )*Z( I ) + DELTA( IP1 )*
+     $                         DELTA( IP1 )*( DPSI+DPHI )
+                        ELSE
+                           A = Z( IP1 )*Z( IP1 ) +
+     $                         DELTA( I )*DELTA( I )*( DPSI+DPHI )
+                        END IF
+                     ELSE
+                        A = DELTA( I )*DELTA( I )*DPSI +
+     $                      DELTA( IP1 )*DELTA( IP1 )*DPHI
+                     END IF
+                  END IF
+                  ETA = B / A
+               ELSE IF( A.LE.ZERO ) THEN
+                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+               ELSE
+                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+               END IF
+            ELSE
+*
+*              Interpolation using THREE most relevant poles
+*
+               TEMP = RHOINV + PSI + PHI
+               IF( SWTCH ) THEN
+                  C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
+                  ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
+                  ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
+               ELSE
+                  IF( ORGATI ) THEN
+                     TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+                     TEMP1 = TEMP1*TEMP1
+                     C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+     $                   ( D( IIM1 )-D( IIP1 ) )*TEMP1
+                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+                     ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+     $                         ( ( DPSI-TEMP1 )+DPHI )
+                  ELSE
+                     TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+                     TEMP1 = TEMP1*TEMP1
+                     C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+     $                   ( D( IIP1 )-D( IIM1 ) )*TEMP1
+                     ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+     $                         ( DPSI+( DPHI-TEMP1 ) )
+                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+                  END IF
+               END IF
+               CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+     $                      INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 250
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GE.ZERO )
+     $         ETA = -W / DW
+            TEMP = TAU + ETA
+            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+               IF( W.LT.ZERO ) THEN
+                  ETA = ( DLTUB-TAU ) / TWO
+               ELSE
+                  ETA = ( DLTLB-TAU ) / TWO
+               END IF
+            END IF
+*
+            DO 210 J = 1, N
+               DELTA( J ) = DELTA( J ) - ETA
+  210       CONTINUE
+*
+            TAU = TAU + ETA
+            PREW = W
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 220 J = 1, IIM1
+               TEMP = Z( J ) / DELTA( J )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+  220       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            DPHI = ZERO
+            PHI = ZERO
+            DO 230 J = N, IIP1, -1
+               TEMP = Z( J ) / DELTA( J )
+               PHI = PHI + Z( J )*TEMP
+               DPHI = DPHI + TEMP*TEMP
+               ERRETM = ERRETM + PHI
+  230       CONTINUE
+*
+            TEMP = Z( II ) / DELTA( II )
+            DW = DPSI + DPHI + TEMP*TEMP
+            TEMP = Z( II )*TEMP
+            W = RHOINV + PHI + PSI + TEMP
+            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $               THREE*ABS( TEMP ) + ABS( TAU )*DW
+            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+     $         SWTCH = .NOT.SWTCH
+*
+  240    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+         IF( ORGATI ) THEN
+            DLAM = D( I ) + TAU
+         ELSE
+            DLAM = D( IP1 ) + TAU
+         END IF
+*
+      END IF
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of DLAED4
+*
+      END
diff --git a/SRC/dlaed5.f b/SRC/dlaed5.f
new file mode 100644
index 00000000..ca7e9056
--- /dev/null
+++ b/SRC/dlaed5.f
@@ -0,0 +1,124 @@
+      SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I
+      DOUBLE PRECISION   DLAM, RHO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( 2 ), DELTA( 2 ), Z( 2 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the I-th eigenvalue of a symmetric rank-one
+*  modification of a 2-by-2 diagonal matrix
+*
+*             diag( D )  +  RHO *  Z * transpose(Z) .
+*
+*  The diagonal elements in the array D are assumed to satisfy
+*
+*             D(i) < D(j)  for  i < j .
+*
+*  We also assume RHO > 0 and that the Euclidean norm of the vector
+*  Z is one.
+*
+*  Arguments
+*  =========
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  I = 1 or I = 2.
+*
+*  D      (input) DOUBLE PRECISION array, dimension (2)
+*         The original eigenvalues.  We assume D(1) < D(2).
+*
+*  Z      (input) DOUBLE PRECISION array, dimension (2)
+*         The components of the updating vector.
+*
+*  DELTA  (output) DOUBLE PRECISION array, dimension (2)
+*         The vector DELTA contains the information necessary
+*         to construct the eigenvectors.
+*
+*  RHO    (input) DOUBLE PRECISION
+*         The scalar in the symmetric updating formula.
+*
+*  DLAM   (output) DOUBLE PRECISION
+*         The computed lambda_I, the I-th updated eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   FOUR = 4.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   B, C, DEL, TAU, TEMP, W
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      DEL = D( 2 ) - D( 1 )
+      IF( I.EQ.1 ) THEN
+         W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
+         IF( W.GT.ZERO ) THEN
+            B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 1 )*Z( 1 )*DEL
+*
+*           B > ZERO, always
+*
+            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+            DLAM = D( 1 ) + TAU
+            DELTA( 1 ) = -Z( 1 ) / TAU
+            DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+         ELSE
+            B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 2 )*Z( 2 )*DEL
+            IF( B.GT.ZERO ) THEN
+               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+            ELSE
+               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+            END IF
+            DLAM = D( 2 ) + TAU
+            DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+            DELTA( 2 ) = -Z( 2 ) / TAU
+         END IF
+         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+         DELTA( 1 ) = DELTA( 1 ) / TEMP
+         DELTA( 2 ) = DELTA( 2 ) / TEMP
+      ELSE
+*
+*     Now I=2
+*
+         B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+         C = RHO*Z( 2 )*Z( 2 )*DEL
+         IF( B.GT.ZERO ) THEN
+            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+         ELSE
+            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+         END IF
+         DLAM = D( 2 ) + TAU
+         DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+         DELTA( 2 ) = -Z( 2 ) / TAU
+         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+         DELTA( 1 ) = DELTA( 1 ) / TEMP
+         DELTA( 2 ) = DELTA( 2 ) / TEMP
+      END IF
+      RETURN
+*
+*     End OF DLAED5
+*
+      END
diff --git a/SRC/dlaed6.f b/SRC/dlaed6.f
new file mode 100644
index 00000000..58a48b1a
--- /dev/null
+++ b/SRC/dlaed6.f
@@ -0,0 +1,327 @@
+      SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     February 2007
+*
+*     .. Scalar Arguments ..
+      LOGICAL            ORGATI
+      INTEGER            INFO, KNITER
+      DOUBLE PRECISION   FINIT, RHO, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( 3 ), Z( 3 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED6 computes the positive or negative root (closest to the origin)
+*  of
+*                   z(1)        z(2)        z(3)
+*  f(x) =   rho + --------- + ---------- + ---------
+*                  d(1)-x      d(2)-x      d(3)-x
+*
+*  It is assumed that
+*
+*        if ORGATI = .true. the root is between d(2) and d(3);
+*        otherwise it is between d(1) and d(2)
+*
+*  This routine will be called by DLAED4 when necessary. In most cases,
+*  the root sought is the smallest in magnitude, though it might not be
+*  in some extremely rare situations.
+*
+*  Arguments
+*  =========
+*
+*  KNITER       (input) INTEGER
+*               Refer to DLAED4 for its significance.
+*
+*  ORGATI       (input) LOGICAL
+*               If ORGATI is true, the needed root is between d(2) and
+*               d(3); otherwise it is between d(1) and d(2).  See
+*               DLAED4 for further details.
+*
+*  RHO          (input) DOUBLE PRECISION
+*               Refer to the equation f(x) above.
+*
+*  D            (input) DOUBLE PRECISION array, dimension (3)
+*               D satisfies d(1) < d(2) < d(3).
+*
+*  Z            (input) DOUBLE PRECISION array, dimension (3)
+*               Each of the elements in z must be positive.
+*
+*  FINIT        (input) DOUBLE PRECISION
+*               The value of f at 0. It is more accurate than the one
+*               evaluated inside this routine (if someone wants to do
+*               so).
+*
+*  TAU          (output) DOUBLE PRECISION
+*               The root of the equation f(x).
+*
+*  INFO         (output) INTEGER
+*               = 0: successful exit
+*               > 0: if INFO = 1, failure to converge
+*
+*  Further Details
+*  ===============
+*
+*  30/06/99: Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  10/02/03: This version has a few statements commented out for thread
+*  safety (machine parameters are computed on each entry). SJH.
+*
+*  05/10/06: Modified from a new version of Ren-Cang Li, use
+*     Gragg-Thornton-Warner cubic convergent scheme for better stability.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 40 )
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DSCALE( 3 ), ZSCALE( 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SCALE
+      INTEGER            I, ITER, NITER
+      DOUBLE PRECISION   A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
+     $                   FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
+     $                   SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, 
+     $                   LBD, UBD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+      IF( ORGATI ) THEN
+         LBD = D(2)
+         UBD = D(3)
+      ELSE
+         LBD = D(1)
+         UBD = D(2)
+      END IF
+      IF( FINIT .LT. ZERO )THEN
+         LBD = ZERO
+      ELSE
+         UBD = ZERO 
+      END IF
+*
+      NITER = 1
+      TAU = ZERO
+      IF( KNITER.EQ.2 ) THEN
+         IF( ORGATI ) THEN
+            TEMP = ( D( 3 )-D( 2 ) ) / TWO
+            C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
+            A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
+            B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
+         ELSE
+            TEMP = ( D( 1 )-D( 2 ) ) / TWO
+            C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
+            A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
+            B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
+         END IF
+         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+         A = A / TEMP
+         B = B / TEMP
+         C = C / TEMP
+         IF( C.EQ.ZERO ) THEN
+            TAU = B / A
+         ELSE IF( A.LE.ZERO ) THEN
+            TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+         IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+     $      TAU = ( LBD+UBD )/TWO
+         IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
+            TAU = ZERO
+         ELSE
+            TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
+     $                     TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
+     $                     TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
+            IF( TEMP .LE. ZERO )THEN
+               LBD = TAU
+            ELSE
+               UBD = TAU
+            END IF
+            IF( ABS( FINIT ).LE.ABS( TEMP ) )
+     $         TAU = ZERO
+         END IF
+      END IF
+*
+*     get machine parameters for possible scaling to avoid overflow
+*
+*     modified by Sven: parameters SMALL1, SMINV1, SMALL2,
+*     SMINV2, EPS are not SAVEd anymore between one call to the
+*     others but recomputed at each call
+*
+      EPS = DLAMCH( 'Epsilon' )
+      BASE = DLAMCH( 'Base' )
+      SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /
+     $         THREE ) )
+      SMINV1 = ONE / SMALL1
+      SMALL2 = SMALL1*SMALL1
+      SMINV2 = SMINV1*SMINV1
+*
+*     Determine if scaling of inputs necessary to avoid overflow
+*     when computing 1/TEMP**3
+*
+      IF( ORGATI ) THEN
+         TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
+      ELSE
+         TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
+      END IF
+      SCALE = .FALSE.
+      IF( TEMP.LE.SMALL1 ) THEN
+         SCALE = .TRUE.
+         IF( TEMP.LE.SMALL2 ) THEN
+*
+*        Scale up by power of radix nearest 1/SAFMIN**(2/3)
+*
+            SCLFAC = SMINV2
+            SCLINV = SMALL2
+         ELSE
+*
+*        Scale up by power of radix nearest 1/SAFMIN**(1/3)
+*
+            SCLFAC = SMINV1
+            SCLINV = SMALL1
+         END IF
+*
+*        Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
+*
+         DO 10 I = 1, 3
+            DSCALE( I ) = D( I )*SCLFAC
+            ZSCALE( I ) = Z( I )*SCLFAC
+   10    CONTINUE
+         TAU = TAU*SCLFAC
+         LBD = LBD*SCLFAC
+         UBD = UBD*SCLFAC
+      ELSE
+*
+*        Copy D and Z to DSCALE and ZSCALE
+*
+         DO 20 I = 1, 3
+            DSCALE( I ) = D( I )
+            ZSCALE( I ) = Z( I )
+   20    CONTINUE
+      END IF
+*
+      FC = ZERO
+      DF = ZERO
+      DDF = ZERO
+      DO 30 I = 1, 3
+         TEMP = ONE / ( DSCALE( I )-TAU )
+         TEMP1 = ZSCALE( I )*TEMP
+         TEMP2 = TEMP1*TEMP
+         TEMP3 = TEMP2*TEMP
+         FC = FC + TEMP1 / DSCALE( I )
+         DF = DF + TEMP2
+         DDF = DDF + TEMP3
+   30 CONTINUE
+      F = FINIT + TAU*FC
+*
+      IF( ABS( F ).LE.ZERO )
+     $   GO TO 60
+      IF( F .LE. ZERO )THEN
+         LBD = TAU
+      ELSE
+         UBD = TAU
+      END IF
+*
+*        Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
+*                            scheme
+*
+*     It is not hard to see that
+*
+*           1) Iterations will go up monotonically
+*              if FINIT < 0;
+*
+*           2) Iterations will go down monotonically
+*              if FINIT > 0.
+*
+      ITER = NITER + 1
+*
+      DO 50 NITER = ITER, MAXIT
+*
+         IF( ORGATI ) THEN
+            TEMP1 = DSCALE( 2 ) - TAU
+            TEMP2 = DSCALE( 3 ) - TAU
+         ELSE
+            TEMP1 = DSCALE( 1 ) - TAU
+            TEMP2 = DSCALE( 2 ) - TAU
+         END IF
+         A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
+         B = TEMP1*TEMP2*F
+         C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
+         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+         A = A / TEMP
+         B = B / TEMP
+         C = C / TEMP
+         IF( C.EQ.ZERO ) THEN
+            ETA = B / A
+         ELSE IF( A.LE.ZERO ) THEN
+            ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+         IF( F*ETA.GE.ZERO ) THEN
+            ETA = -F / DF
+         END IF
+*
+         TAU = TAU + ETA
+         IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+     $      TAU = ( LBD + UBD )/TWO 
+*
+         FC = ZERO
+         ERRETM = ZERO
+         DF = ZERO
+         DDF = ZERO
+         DO 40 I = 1, 3
+            TEMP = ONE / ( DSCALE( I )-TAU )
+            TEMP1 = ZSCALE( I )*TEMP
+            TEMP2 = TEMP1*TEMP
+            TEMP3 = TEMP2*TEMP
+            TEMP4 = TEMP1 / DSCALE( I )
+            FC = FC + TEMP4
+            ERRETM = ERRETM + ABS( TEMP4 )
+            DF = DF + TEMP2
+            DDF = DDF + TEMP3
+   40    CONTINUE
+         F = FINIT + TAU*FC
+         ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
+     $            ABS( TAU )*DF
+         IF( ABS( F ).LE.EPS*ERRETM )
+     $      GO TO 60
+         IF( F .LE. ZERO )THEN
+            LBD = TAU
+         ELSE
+            UBD = TAU
+         END IF
+   50 CONTINUE
+      INFO = 1
+   60 CONTINUE
+*
+*     Undo scaling
+*
+      IF( SCALE )
+     $   TAU = TAU*SCLINV
+      RETURN
+*
+*     End of DLAED6
+*
+      END
diff --git a/SRC/dlaed7.f b/SRC/dlaed7.f
new file mode 100644
index 00000000..28b357f8
--- /dev/null
+++ b/SRC/dlaed7.f
@@ -0,0 +1,287 @@
+      SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
+     $                   LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
+     $                   PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
+     $                   QSIZ, TLVLS
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
+     $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
+      DOUBLE PRECISION   D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
+     $                   QSTORE( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED7 computes the updated eigensystem of a diagonal
+*  matrix after modification by a rank-one symmetric matrix. This
+*  routine is used only for the eigenproblem which requires all
+*  eigenvalues and optionally eigenvectors of a dense symmetric matrix
+*  that has been reduced to tridiagonal form.  DLAED1 handles
+*  the case in which all eigenvalues and eigenvectors of a symmetric
+*  tridiagonal matrix are desired.
+*
+*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+*     where Z = Q'u, u is a vector of length N with ones in the
+*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+*     The eigenvectors of the original matrix are stored in Q, and the
+*     eigenvalues are in D.  The algorithm consists of three stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple eigenvalues or if there is a zero in
+*        the Z vector.  For each such occurence the dimension of the
+*        secular equation problem is reduced by one.  This stage is
+*        performed by the routine DLAED8.
+*
+*        The second stage consists of calculating the updated
+*        eigenvalues. This is done by finding the roots of the secular
+*        equation via the routine DLAED4 (as called by DLAED9).
+*        This routine also calculates the eigenvectors of the current
+*        problem.
+*
+*        The final stage consists of computing the updated eigenvectors
+*        directly using the updated eigenvalues.  The eigenvectors for
+*        the current problem are multiplied with the eigenvectors from
+*        the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          = 0:  Compute eigenvalues only.
+*          = 1:  Compute eigenvectors of original dense symmetric matrix
+*                also.  On entry, Q contains the orthogonal matrix used
+*                to reduce the original matrix to tridiagonal form.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the orthogonal matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  TLVLS  (input) INTEGER
+*         The total number of merging levels in the overall divide and
+*         conquer tree.
+*
+*  CURLVL (input) INTEGER
+*         The current level in the overall merge routine,
+*         0 <= CURLVL <= TLVLS.
+*
+*  CURPBM (input) INTEGER
+*         The current problem in the current level in the overall
+*         merge routine (counting from upper left to lower right).
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, the eigenvalues of the rank-1-perturbed matrix.
+*         On exit, the eigenvalues of the repaired matrix.
+*
+*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+*         On entry, the eigenvectors of the rank-1-perturbed matrix.
+*         On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (output) INTEGER array, dimension (N)
+*         The permutation which will reintegrate the subproblem just
+*         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
+*         will be in ascending order.
+*
+*  RHO    (input) DOUBLE PRECISION
+*         The subdiagonal element used to create the rank-1
+*         modification.
+*
+*  CUTPNT (input) INTEGER
+*         Contains the location of the last eigenvalue in the leading
+*         sub-matrix.  min(1,N) <= CUTPNT <= N.
+*
+*  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
+*         Stores eigenvectors of submatrices encountered during
+*         divide and conquer, packed together. QPTR points to
+*         beginning of the submatrices.
+*
+*  QPTR   (input/output) INTEGER array, dimension (N+2)
+*         List of indices pointing to beginning of submatrices stored
+*         in QSTORE. The submatrices are numbered starting at the
+*         bottom left of the divide and conquer tree, from left to
+*         right and bottom to top.
+*
+*  PRMPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in PERM a
+*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
+*         indicates the size of the permutation and also the size of
+*         the full, non-deflated problem.
+*
+*  PERM   (input) INTEGER array, dimension (N lg N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in GIVCOL a
+*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
+*         indicates the number of Givens rotations.
+*
+*  GIVCOL (input) INTEGER array, dimension (2, N lg N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
+     $                   IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED7', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in DLAED8 and DLAED9.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         LDQ2 = QSIZ
+      ELSE
+         LDQ2 = N
+      END IF
+*
+      IZ = 1
+      IDLMDA = IZ + N
+      IW = IDLMDA + N
+      IQ2 = IW + N
+      IS = IQ2 + N*LDQ2
+*
+      INDX = 1
+      INDXC = INDX + N
+      COLTYP = INDXC + N
+      INDXP = COLTYP + N
+*
+*     Form the z-vector which consists of the last row of Q_1 and the
+*     first row of Q_2.
+*
+      PTR = 1 + 2**TLVLS
+      DO 10 I = 1, CURLVL - 1
+         PTR = PTR + 2**( TLVLS-I )
+   10 CONTINUE
+      CURR = PTR + CURPBM
+      CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+     $             GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
+     $             WORK( IZ+N ), INFO )
+*
+*     When solving the final problem, we no longer need the stored data,
+*     so we will overwrite the data from this level onto the previously
+*     used storage space.
+*
+      IF( CURLVL.EQ.TLVLS ) THEN
+         QPTR( CURR ) = 1
+         PRMPTR( CURR ) = 1
+         GIVPTR( CURR ) = 1
+      END IF
+*
+*     Sort and Deflate eigenvalues.
+*
+      CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
+     $             WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
+     $             WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
+     $             GIVCOL( 1, GIVPTR( CURR ) ),
+     $             GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
+     $             IWORK( INDX ), INFO )
+      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
+      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
+*
+*     Solve Secular Equation.
+*
+      IF( K.NE.0 ) THEN
+         CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
+     $                WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 30
+         IF( ICOMPQ.EQ.1 ) THEN
+            CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
+     $                  QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
+         END IF
+         QPTR( CURR+1 ) = QPTR( CURR ) + K**2
+*
+*     Prepare the INDXQ sorting permutation.
+*
+         N1 = K
+         N2 = N - K
+         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
+      ELSE
+         QPTR( CURR+1 ) = QPTR( CURR )
+         DO 20 I = 1, N
+            INDXQ( I ) = I
+   20    CONTINUE
+      END IF
+*
+   30 CONTINUE
+      RETURN
+*
+*     End of DLAED7
+*
+      END
diff --git a/SRC/dlaed8.f b/SRC/dlaed8.f
new file mode 100644
index 00000000..47076107
--- /dev/null
+++ b/SRC/dlaed8.f
@@ -0,0 +1,399 @@
+      SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
+     $                   CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
+     $                   GIVCOL, GIVNUM, INDXP, INDX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
+     $                   QSIZ
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),
+     $                   INDXQ( * ), PERM( * )
+      DOUBLE PRECISION   D( * ), DLAMDA( * ), GIVNUM( 2, * ),
+     $                   Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED8 merges the two sets of eigenvalues together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  eigenvalues are close together or if there is a tiny element in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          = 0:  Compute eigenvalues only.
+*          = 1:  Compute eigenvectors of original dense symmetric matrix
+*                also.  On entry, Q contains the orthogonal matrix used
+*                to reduce the original matrix to tridiagonal form.
+*
+*  K      (output) INTEGER
+*         The number of non-deflated eigenvalues, and the order of the
+*         related secular equation.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the orthogonal matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, the eigenvalues of the two submatrices to be
+*         combined.  On exit, the trailing (N-K) updated eigenvalues
+*         (those which were deflated) sorted into increasing order.
+*
+*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*         If ICOMPQ = 0, Q is not referenced.  Otherwise,
+*         on entry, Q contains the eigenvectors of the partially solved
+*         system which has been previously updated in matrix
+*         multiplies with other partially solved eigensystems.
+*         On exit, Q contains the trailing (N-K) updated eigenvectors
+*         (those which were deflated) in its last N-K columns.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (input) INTEGER array, dimension (N)
+*         The permutation which separately sorts the two sub-problems
+*         in D into ascending order.  Note that elements in the second
+*         half of this permutation must first have CUTPNT added to
+*         their values in order to be accurate.
+*
+*  RHO    (input/output) DOUBLE PRECISION
+*         On entry, the off-diagonal element associated with the rank-1
+*         cut which originally split the two submatrices which are now
+*         being recombined.
+*         On exit, RHO has been modified to the value required by
+*         DLAED3.
+*
+*  CUTPNT (input) INTEGER
+*         The location of the last eigenvalue in the leading
+*         sub-matrix.  min(1,N) <= CUTPNT <= N.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension (N)
+*         On entry, Z contains the updating vector (the last row of
+*         the first sub-eigenvector matrix and the first row of the
+*         second sub-eigenvector matrix).
+*         On exit, the contents of Z are destroyed by the updating
+*         process.
+*
+*  DLAMDA (output) DOUBLE PRECISION array, dimension (N)
+*         A copy of the first K eigenvalues which will be used by
+*         DLAED3 to form the secular equation.
+*
+*  Q2     (output) DOUBLE PRECISION array, dimension (LDQ2,N)
+*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
+*         a copy of the first K eigenvectors which will be used by
+*         DLAED7 in a matrix multiply (DGEMM) to update the new
+*         eigenvectors.
+*
+*  LDQ2   (input) INTEGER
+*         The leading dimension of the array Q2.  LDQ2 >= max(1,N).
+*
+*  W      (output) DOUBLE PRECISION array, dimension (N)
+*         The first k values of the final deflation-altered z-vector and
+*         will be passed to DLAED3.
+*
+*  PERM   (output) INTEGER array, dimension (N)
+*         The permutations (from deflation and sorting) to be applied
+*         to each eigenblock.
+*
+*  GIVPTR (output) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem.
+*
+*  GIVCOL (output) INTEGER array, dimension (2, N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  INDXP  (workspace) INTEGER array, dimension (N)
+*         The permutation used to place deflated values of D at the end
+*         of the array.  INDXP(1:K) points to the nondeflated D-values
+*         and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+*  INDX   (workspace) INTEGER array, dimension (N)
+*         The permutation used to sort the contents of D into ascending
+*         order.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
+     $                   TWO = 2.0D0, EIGHT = 8.0D0 )
+*     ..
+*     .. Local Scalars ..
+*
+      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
+      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           IDAMAX, DLAMCH, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
+         INFO = -10
+      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED8', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      N1 = CUTPNT
+      N2 = N - N1
+      N1P1 = N1 + 1
+*
+      IF( RHO.LT.ZERO ) THEN
+         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
+      END IF
+*
+*     Normalize z so that norm(z) = 1
+*
+      T = ONE / SQRT( TWO )
+      DO 10 J = 1, N
+         INDX( J ) = J
+   10 CONTINUE
+      CALL DSCAL( N, T, Z, 1 )
+      RHO = ABS( TWO*RHO )
+*
+*     Sort the eigenvalues into increasing order
+*
+      DO 20 I = CUTPNT + 1, N
+         INDXQ( I ) = INDXQ( I ) + CUTPNT
+   20 CONTINUE
+      DO 30 I = 1, N
+         DLAMDA( I ) = D( INDXQ( I ) )
+         W( I ) = Z( INDXQ( I ) )
+   30 CONTINUE
+      I = 1
+      J = CUTPNT + 1
+      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
+      DO 40 I = 1, N
+         D( I ) = DLAMDA( INDX( I ) )
+         Z( I ) = W( INDX( I ) )
+   40 CONTINUE
+*
+*     Calculate the allowable deflation tolerence
+*
+      IMAX = IDAMAX( N, Z, 1 )
+      JMAX = IDAMAX( N, D, 1 )
+      EPS = DLAMCH( 'Epsilon' )
+      TOL = EIGHT*EPS*ABS( D( JMAX ) )
+*
+*     If the rank-1 modifier is small enough, no more needs to be done
+*     except to reorganize Q so that its columns correspond with the
+*     elements in D.
+*
+      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+         K = 0
+         IF( ICOMPQ.EQ.0 ) THEN
+            DO 50 J = 1, N
+               PERM( J ) = INDXQ( INDX( J ) )
+   50       CONTINUE
+         ELSE
+            DO 60 J = 1, N
+               PERM( J ) = INDXQ( INDX( J ) )
+               CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+   60       CONTINUE
+            CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
+     $                   LDQ )
+         END IF
+         RETURN
+      END IF
+*
+*     If there are multiple eigenvalues then the problem deflates.  Here
+*     the number of equal eigenvalues are found.  As each equal
+*     eigenvalue is found, an elementary reflector is computed to rotate
+*     the corresponding eigensubspace so that the corresponding
+*     components of Z are zero in this new basis.
+*
+      K = 0
+      GIVPTR = 0
+      K2 = N + 1
+      DO 70 J = 1, N
+         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            INDXP( K2 ) = J
+            IF( J.EQ.N )
+     $         GO TO 110
+         ELSE
+            JLAM = J
+            GO TO 80
+         END IF
+   70 CONTINUE
+   80 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 100
+      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         INDXP( K2 ) = J
+      ELSE
+*
+*        Check if eigenvalues are close enough to allow deflation.
+*
+         S = Z( JLAM )
+         C = Z( J )
+*
+*        Find sqrt(a**2+b**2) without overflow or
+*        destructive underflow.
+*
+         TAU = DLAPY2( C, S )
+         T = D( J ) - D( JLAM )
+         C = C / TAU
+         S = -S / TAU
+         IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            Z( J ) = TAU
+            Z( JLAM ) = ZERO
+*
+*           Record the appropriate Givens rotation
+*
+            GIVPTR = GIVPTR + 1
+            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
+            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
+            GIVNUM( 1, GIVPTR ) = C
+            GIVNUM( 2, GIVPTR ) = S
+            IF( ICOMPQ.EQ.1 ) THEN
+               CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
+     $                    Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
+            END IF
+            T = D( JLAM )*C*C + D( J )*S*S
+            D( J ) = D( JLAM )*S*S + D( J )*C*C
+            D( JLAM ) = T
+            K2 = K2 - 1
+            I = 1
+   90       CONTINUE
+            IF( K2+I.LE.N ) THEN
+               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
+                  INDXP( K2+I-1 ) = INDXP( K2+I )
+                  INDXP( K2+I ) = JLAM
+                  I = I + 1
+                  GO TO 90
+               ELSE
+                  INDXP( K2+I-1 ) = JLAM
+               END IF
+            ELSE
+               INDXP( K2+I-1 ) = JLAM
+            END IF
+            JLAM = J
+         ELSE
+            K = K + 1
+            W( K ) = Z( JLAM )
+            DLAMDA( K ) = D( JLAM )
+            INDXP( K ) = JLAM
+            JLAM = J
+         END IF
+      END IF
+      GO TO 80
+  100 CONTINUE
+*
+*     Record the last eigenvalue.
+*
+      K = K + 1
+      W( K ) = Z( JLAM )
+      DLAMDA( K ) = D( JLAM )
+      INDXP( K ) = JLAM
+*
+  110 CONTINUE
+*
+*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+*     and Q2 respectively.  The eigenvalues/vectors which were not
+*     deflated go into the first K slots of DLAMDA and Q2 respectively,
+*     while those which were deflated go into the last N - K slots.
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+         DO 120 J = 1, N
+            JP = INDXP( J )
+            DLAMDA( J ) = D( JP )
+            PERM( J ) = INDXQ( INDX( JP ) )
+  120    CONTINUE
+      ELSE
+         DO 130 J = 1, N
+            JP = INDXP( J )
+            DLAMDA( J ) = D( JP )
+            PERM( J ) = INDXQ( INDX( JP ) )
+            CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+  130    CONTINUE
+      END IF
+*
+*     The deflated eigenvalues and their corresponding vectors go back
+*     into the last N - K slots of D and Q respectively.
+*
+      IF( K.LT.N ) THEN
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+         ELSE
+            CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+            CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
+     $                   Q( 1, K+1 ), LDQ )
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLAED8
+*
+      END
diff --git a/SRC/dlaed9.f b/SRC/dlaed9.f
new file mode 100644
index 00000000..ca1c67a0
--- /dev/null
+++ b/SRC/dlaed9.f
@@ -0,0 +1,205 @@
+      SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
+     $                   S, LDS, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, KSTART, KSTOP, LDQ, LDS, N
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
+     $                   W( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAED9 finds the roots of the secular equation, as defined by the
+*  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the
+*  appropriate calls to DLAED4 and then stores the new matrix of
+*  eigenvectors for use in calculating the next level of Z vectors.
+*
+*  Arguments
+*  =========
+*
+*  K       (input) INTEGER
+*          The number of terms in the rational function to be solved by
+*          DLAED4.  K >= 0.
+*
+*  KSTART  (input) INTEGER
+*  KSTOP   (input) INTEGER
+*          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
+*          are to be computed.  1 <= KSTART <= KSTOP <= K.
+*
+*  N       (input) INTEGER
+*          The number of rows and columns in the Q matrix.
+*          N >= K (delation may result in N > K).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          D(I) contains the updated eigenvalues
+*          for KSTART <= I <= KSTOP.
+*
+*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= max( 1, N ).
+*
+*  RHO     (input) DOUBLE PRECISION
+*          The value of the parameter in the rank one update equation.
+*          RHO >= 0 required.
+*
+*  DLAMDA  (input) DOUBLE PRECISION array, dimension (K)
+*          The first K elements of this array contain the old roots
+*          of the deflated updating problem.  These are the poles
+*          of the secular equation.
+*
+*  W       (input) DOUBLE PRECISION array, dimension (K)
+*          The first K elements of this array contain the components
+*          of the deflation-adjusted updating vector.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (LDS, K)
+*          Will contain the eigenvectors of the repaired matrix which
+*          will be stored for subsequent Z vector calculation and
+*          multiplied by the previously accumulated eigenvectors
+*          to update the system.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of S.  LDS >= max( 1, K ).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3, DNRM2
+      EXTERNAL           DLAMC3, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAED4, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( K.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
+         INFO = -2
+      ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( N.LT.K ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAED9', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 )
+     $   RETURN
+*
+*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DLAMDA(I) if it is 1; this makes the subsequent
+*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DLAMDA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DLAMDA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 10 I = 1, N
+         DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+   10 CONTINUE
+*
+      DO 20 J = KSTART, KSTOP
+         CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+*        If the zero finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 )
+     $      GO TO 120
+   20 CONTINUE
+*
+      IF( K.EQ.1 .OR. K.EQ.2 ) THEN
+         DO 40 I = 1, K
+            DO 30 J = 1, K
+               S( J, I ) = Q( J, I )
+   30       CONTINUE
+   40    CONTINUE
+         GO TO 120
+      END IF
+*
+*     Compute updated W.
+*
+      CALL DCOPY( K, W, 1, S, 1 )
+*
+*     Initialize W(I) = Q(I,I)
+*
+      CALL DCOPY( K, Q, LDQ+1, W, 1 )
+      DO 70 J = 1, K
+         DO 50 I = 1, J - 1
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   50    CONTINUE
+         DO 60 I = J + 1, K
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   60    CONTINUE
+   70 CONTINUE
+      DO 80 I = 1, K
+         W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
+   80 CONTINUE
+*
+*     Compute eigenvectors of the modified rank-1 modification.
+*
+      DO 110 J = 1, K
+         DO 90 I = 1, K
+            Q( I, J ) = W( I ) / Q( I, J )
+   90    CONTINUE
+         TEMP = DNRM2( K, Q( 1, J ), 1 )
+         DO 100 I = 1, K
+            S( I, J ) = Q( I, J ) / TEMP
+  100    CONTINUE
+  110 CONTINUE
+*
+  120 CONTINUE
+      RETURN
+*
+*     End of DLAED9
+*
+      END
diff --git a/SRC/dlaeda.f b/SRC/dlaeda.f
new file mode 100644
index 00000000..f5be4184
--- /dev/null
+++ b/SRC/dlaeda.f
@@ -0,0 +1,217 @@
+      SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+     $                   GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CURLVL, CURPBM, INFO, N, TLVLS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
+     $                   PRMPTR( * ), QPTR( * )
+      DOUBLE PRECISION   GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAEDA computes the Z vector corresponding to the merge step in the
+*  CURLVLth step of the merge process with TLVLS steps for the CURPBMth
+*  problem.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  TLVLS  (input) INTEGER
+*         The total number of merging levels in the overall divide and
+*         conquer tree.
+*
+*  CURLVL (input) INTEGER
+*         The current level in the overall merge routine,
+*         0 <= curlvl <= tlvls.
+*
+*  CURPBM (input) INTEGER
+*         The current problem in the current level in the overall
+*         merge routine (counting from upper left to lower right).
+*
+*  PRMPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in PERM a
+*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
+*         indicates the size of the permutation and incidentally the
+*         size of the full, non-deflated problem.
+*
+*  PERM   (input) INTEGER array, dimension (N lg N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in GIVCOL a
+*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
+*         indicates the number of Givens rotations.
+*
+*  GIVCOL (input) INTEGER array, dimension (2, N lg N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  Q      (input) DOUBLE PRECISION array, dimension (N**2)
+*         Contains the square eigenblocks from previous levels, the
+*         starting positions for blocks are given by QPTR.
+*
+*  QPTR   (input) INTEGER array, dimension (N+2)
+*         Contains a list of pointers which indicate where in Q an
+*         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates
+*         the size of the block.
+*
+*  Z      (output) DOUBLE PRECISION array, dimension (N)
+*         On output this vector contains the updating vector (the last
+*         row of the first sub-eigenvector matrix and the first row of
+*         the second sub-eigenvector matrix).
+*
+*  ZTEMP  (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
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
+     $                   PTR, ZPTR1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMV, DROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, INT, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAEDA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine location of first number in second half.
+*
+      MID = N / 2 + 1
+*
+*     Gather last/first rows of appropriate eigenblocks into center of Z
+*
+      PTR = 1
+*
+*     Determine location of lowest level subproblem in the full storage
+*     scheme
+*
+      CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
+*
+*     Determine size of these matrices.  We add HALF to the value of
+*     the SQRT in case the machine underestimates one of these square
+*     roots.
+*
+      BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+      BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
+      DO 10 K = 1, MID - BSIZ1 - 1
+         Z( K ) = ZERO
+   10 CONTINUE
+      CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
+     $            Z( MID-BSIZ1 ), 1 )
+      CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
+      DO 20 K = MID + BSIZ2, N
+         Z( K ) = ZERO
+   20 CONTINUE
+*
+*     Loop thru remaining levels 1 -> CURLVL applying the Givens
+*     rotations and permutation and then multiplying the center matrices
+*     against the current Z.
+*
+      PTR = 2**TLVLS + 1
+      DO 70 K = 1, CURLVL - 1
+         CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
+         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+         ZPTR1 = MID - PSIZ1
+*
+*       Apply Givens at CURR and CURR+1
+*
+         DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
+            CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
+     $                 Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
+     $                 GIVNUM( 2, I ) )
+   30    CONTINUE
+         DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
+            CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
+     $                 Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
+     $                 GIVNUM( 2, I ) )
+   40    CONTINUE
+         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+         DO 50 I = 0, PSIZ1 - 1
+            ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
+   50    CONTINUE
+         DO 60 I = 0, PSIZ2 - 1
+            ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
+   60    CONTINUE
+*
+*        Multiply Blocks at CURR and CURR+1
+*
+*        Determine size of these matrices.  We add HALF to the value of
+*        the SQRT in case the machine underestimates one of these
+*        square roots.
+*
+         BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+         BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+
+     $           1 ) ) ) )
+         IF( BSIZ1.GT.0 ) THEN
+            CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
+     $                  BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
+         END IF
+         CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
+     $               1 )
+         IF( BSIZ2.GT.0 ) THEN
+            CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
+     $                  BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
+         END IF
+         CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
+     $               Z( MID+BSIZ2 ), 1 )
+*
+         PTR = PTR + 2**( TLVLS-K )
+   70 CONTINUE
+*
+      RETURN
+*
+*     End of DLAEDA
+*
+      END
diff --git a/SRC/dlaein.f b/SRC/dlaein.f
new file mode 100644
index 00000000..9f9b5fa5
--- /dev/null
+++ b/SRC/dlaein.f
@@ -0,0 +1,531 @@
+      SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
+     $                   LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            NOINIT, RIGHTV
+      INTEGER            INFO, LDB, LDH, N
+      DOUBLE PRECISION   BIGNUM, EPS3, SMLNUM, WI, WR
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAEIN uses inverse iteration to find a right or left eigenvector
+*  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
+*  matrix H.
+*
+*  Arguments
+*  =========
+*
+*  RIGHTV   (input) LOGICAL
+*          = .TRUE. : compute right eigenvector;
+*          = .FALSE.: compute left eigenvector.
+*
+*  NOINIT   (input) LOGICAL
+*          = .TRUE. : no initial vector supplied in (VR,VI).
+*          = .FALSE.: initial vector supplied in (VR,VI).
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) DOUBLE PRECISION array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  WR      (input) DOUBLE PRECISION
+*  WI      (input) DOUBLE PRECISION
+*          The real and imaginary parts of the eigenvalue of H whose
+*          corresponding right or left eigenvector is to be computed.
+*
+*  VR      (input/output) DOUBLE PRECISION array, dimension (N)
+*  VI      (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
+*          a real starting vector for inverse iteration using the real
+*          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
+*          must contain the real and imaginary parts of a complex
+*          starting vector for inverse iteration using the complex
+*          eigenvalue (WR,WI); otherwise VR and VI need not be set.
+*          On exit, if WI = 0.0 (real eigenvalue), VR contains the
+*          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
+*          VR and VI contain the real and imaginary parts of the
+*          computed complex eigenvector. The eigenvector is normalized
+*          so that the component of largest magnitude has magnitude 1;
+*          here the magnitude of a complex number (x,y) is taken to be
+*          |x| + |y|.
+*          VI is not referenced if WI = 0.0.
+*
+*  B       (workspace) DOUBLE PRECISION array, dimension (LDB,N)
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= N+1.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  EPS3    (input) DOUBLE PRECISION
+*          A small machine-dependent value which is used to perturb
+*          close eigenvalues, and to replace zero pivots.
+*
+*  SMLNUM  (input) DOUBLE PRECISION
+*          A machine-dependent value close to the underflow threshold.
+*
+*  BIGNUM  (input) DOUBLE PRECISION
+*          A machine-dependent value close to the overflow threshold.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          = 1:  inverse iteration did not converge; VR is set to the
+*                last iterate, and so is VI if WI.ne.0.0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TENTH
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          NORMIN, TRANS
+      INTEGER            I, I1, I2, I3, IERR, ITS, J
+      DOUBLE PRECISION   ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
+     $                   REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
+     $                   W1, X, XI, XR, Y
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DLAPY2, DNRM2
+      EXTERNAL           IDAMAX, DASUM, DLAPY2, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLADIV, DLATRS, DSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     GROWTO is the threshold used in the acceptance test for an
+*     eigenvector.
+*
+      ROOTN = SQRT( DBLE( N ) )
+      GROWTO = TENTH / ROOTN
+      NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
+*
+*     Form B = H - (WR,WI)*I (except that the subdiagonal elements and
+*     the imaginary parts of the diagonal elements are not stored).
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, J - 1
+            B( I, J ) = H( I, J )
+   10    CONTINUE
+         B( J, J ) = H( J, J ) - WR
+   20 CONTINUE
+*
+      IF( WI.EQ.ZERO ) THEN
+*
+*        Real eigenvalue.
+*
+         IF( NOINIT ) THEN
+*
+*           Set initial vector.
+*
+            DO 30 I = 1, N
+               VR( I ) = EPS3
+   30       CONTINUE
+         ELSE
+*
+*           Scale supplied initial vector.
+*
+            VNORM = DNRM2( N, VR, 1 )
+            CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
+     $                  1 )
+         END IF
+*
+         IF( RIGHTV ) THEN
+*
+*           LU decomposition with partial pivoting of B, replacing zero
+*           pivots by EPS3.
+*
+            DO 60 I = 1, N - 1
+               EI = H( I+1, I )
+               IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
+*
+*                 Interchange rows and eliminate.
+*
+                  X = B( I, I ) / EI
+                  B( I, I ) = EI
+                  DO 40 J = I + 1, N
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - X*TEMP
+                     B( I, J ) = TEMP
+   40             CONTINUE
+               ELSE
+*
+*                 Eliminate without interchange.
+*
+                  IF( B( I, I ).EQ.ZERO )
+     $               B( I, I ) = EPS3
+                  X = EI / B( I, I )
+                  IF( X.NE.ZERO ) THEN
+                     DO 50 J = I + 1, N
+                        B( I+1, J ) = B( I+1, J ) - X*B( I, J )
+   50                CONTINUE
+                  END IF
+               END IF
+   60       CONTINUE
+            IF( B( N, N ).EQ.ZERO )
+     $         B( N, N ) = EPS3
+*
+            TRANS = 'N'
+*
+         ELSE
+*
+*           UL decomposition with partial pivoting of B, replacing zero
+*           pivots by EPS3.
+*
+            DO 90 J = N, 2, -1
+               EJ = H( J, J-1 )
+               IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
+*
+*                 Interchange columns and eliminate.
+*
+                  X = B( J, J ) / EJ
+                  B( J, J ) = EJ
+                  DO 70 I = 1, J - 1
+                     TEMP = B( I, J-1 )
+                     B( I, J-1 ) = B( I, J ) - X*TEMP
+                     B( I, J ) = TEMP
+   70             CONTINUE
+               ELSE
+*
+*                 Eliminate without interchange.
+*
+                  IF( B( J, J ).EQ.ZERO )
+     $               B( J, J ) = EPS3
+                  X = EJ / B( J, J )
+                  IF( X.NE.ZERO ) THEN
+                     DO 80 I = 1, J - 1
+                        B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
+   80                CONTINUE
+                  END IF
+               END IF
+   90       CONTINUE
+            IF( B( 1, 1 ).EQ.ZERO )
+     $         B( 1, 1 ) = EPS3
+*
+            TRANS = 'T'
+*
+         END IF
+*
+         NORMIN = 'N'
+         DO 110 ITS = 1, N
+*
+*           Solve U*x = scale*v for a right eigenvector
+*             or U'*x = scale*v for a left eigenvector,
+*           overwriting x on v.
+*
+            CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
+     $                   VR, SCALE, WORK, IERR )
+            NORMIN = 'Y'
+*
+*           Test for sufficient growth in the norm of v.
+*
+            VNORM = DASUM( N, VR, 1 )
+            IF( VNORM.GE.GROWTO*SCALE )
+     $         GO TO 120
+*
+*           Choose new orthogonal starting vector and try again.
+*
+            TEMP = EPS3 / ( ROOTN+ONE )
+            VR( 1 ) = EPS3
+            DO 100 I = 2, N
+               VR( I ) = TEMP
+  100       CONTINUE
+            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+  110    CONTINUE
+*
+*        Failure to find eigenvector in N iterations.
+*
+         INFO = 1
+*
+  120    CONTINUE
+*
+*        Normalize eigenvector.
+*
+         I = IDAMAX( N, VR, 1 )
+         CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
+      ELSE
+*
+*        Complex eigenvalue.
+*
+         IF( NOINIT ) THEN
+*
+*           Set initial vector.
+*
+            DO 130 I = 1, N
+               VR( I ) = EPS3
+               VI( I ) = ZERO
+  130       CONTINUE
+         ELSE
+*
+*           Scale supplied initial vector.
+*
+            NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) )
+            REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
+            CALL DSCAL( N, REC, VR, 1 )
+            CALL DSCAL( N, REC, VI, 1 )
+         END IF
+*
+         IF( RIGHTV ) THEN
+*
+*           LU decomposition with partial pivoting of B, replacing zero
+*           pivots by EPS3.
+*
+*           The imaginary part of the (i,j)-th element of U is stored in
+*           B(j+1,i).
+*
+            B( 2, 1 ) = -WI
+            DO 140 I = 2, N
+               B( I+1, 1 ) = ZERO
+  140       CONTINUE
+*
+            DO 170 I = 1, N - 1
+               ABSBII = DLAPY2( B( I, I ), B( I+1, I ) )
+               EI = H( I+1, I )
+               IF( ABSBII.LT.ABS( EI ) ) THEN
+*
+*                 Interchange rows and eliminate.
+*
+                  XR = B( I, I ) / EI
+                  XI = B( I+1, I ) / EI
+                  B( I, I ) = EI
+                  B( I+1, I ) = ZERO
+                  DO 150 J = I + 1, N
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - XR*TEMP
+                     B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
+                     B( I, J ) = TEMP
+                     B( J+1, I ) = ZERO
+  150             CONTINUE
+                  B( I+2, I ) = -WI
+                  B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
+                  B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
+               ELSE
+*
+*                 Eliminate without interchanging rows.
+*
+                  IF( ABSBII.EQ.ZERO ) THEN
+                     B( I, I ) = EPS3
+                     B( I+1, I ) = ZERO
+                     ABSBII = EPS3
+                  END IF
+                  EI = ( EI / ABSBII ) / ABSBII
+                  XR = B( I, I )*EI
+                  XI = -B( I+1, I )*EI
+                  DO 160 J = I + 1, N
+                     B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
+     $                             XI*B( J+1, I )
+                     B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
+  160             CONTINUE
+                  B( I+2, I+1 ) = B( I+2, I+1 ) - WI
+               END IF
+*
+*              Compute 1-norm of offdiagonal elements of i-th row.
+*
+               WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) +
+     $                     DASUM( N-I, B( I+2, I ), 1 )
+  170       CONTINUE
+            IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
+     $         B( N, N ) = EPS3
+            WORK( N ) = ZERO
+*
+            I1 = N
+            I2 = 1
+            I3 = -1
+         ELSE
+*
+*           UL decomposition with partial pivoting of conjg(B),
+*           replacing zero pivots by EPS3.
+*
+*           The imaginary part of the (i,j)-th element of U is stored in
+*           B(j+1,i).
+*
+            B( N+1, N ) = WI
+            DO 180 J = 1, N - 1
+               B( N+1, J ) = ZERO
+  180       CONTINUE
+*
+            DO 210 J = N, 2, -1
+               EJ = H( J, J-1 )
+               ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) )
+               IF( ABSBJJ.LT.ABS( EJ ) ) THEN
+*
+*                 Interchange columns and eliminate
+*
+                  XR = B( J, J ) / EJ
+                  XI = B( J+1, J ) / EJ
+                  B( J, J ) = EJ
+                  B( J+1, J ) = ZERO
+                  DO 190 I = 1, J - 1
+                     TEMP = B( I, J-1 )
+                     B( I, J-1 ) = B( I, J ) - XR*TEMP
+                     B( J, I ) = B( J+1, I ) - XI*TEMP
+                     B( I, J ) = TEMP
+                     B( J+1, I ) = ZERO
+  190             CONTINUE
+                  B( J+1, J-1 ) = WI
+                  B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
+                  B( J, J-1 ) = B( J, J-1 ) - XR*WI
+               ELSE
+*
+*                 Eliminate without interchange.
+*
+                  IF( ABSBJJ.EQ.ZERO ) THEN
+                     B( J, J ) = EPS3
+                     B( J+1, J ) = ZERO
+                     ABSBJJ = EPS3
+                  END IF
+                  EJ = ( EJ / ABSBJJ ) / ABSBJJ
+                  XR = B( J, J )*EJ
+                  XI = -B( J+1, J )*EJ
+                  DO 200 I = 1, J - 1
+                     B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
+     $                             XI*B( J+1, I )
+                     B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
+  200             CONTINUE
+                  B( J, J-1 ) = B( J, J-1 ) + WI
+               END IF
+*
+*              Compute 1-norm of offdiagonal elements of j-th column.
+*
+               WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) +
+     $                     DASUM( J-1, B( J+1, 1 ), LDB )
+  210       CONTINUE
+            IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
+     $         B( 1, 1 ) = EPS3
+            WORK( 1 ) = ZERO
+*
+            I1 = 1
+            I2 = N
+            I3 = 1
+         END IF
+*
+         DO 270 ITS = 1, N
+            SCALE = ONE
+            VMAX = ONE
+            VCRIT = BIGNUM
+*
+*           Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
+*             or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
+*           overwriting (xr,xi) on (vr,vi).
+*
+            DO 250 I = I1, I2, I3
+*
+               IF( WORK( I ).GT.VCRIT ) THEN
+                  REC = ONE / VMAX
+                  CALL DSCAL( N, REC, VR, 1 )
+                  CALL DSCAL( N, REC, VI, 1 )
+                  SCALE = SCALE*REC
+                  VMAX = ONE
+                  VCRIT = BIGNUM
+               END IF
+*
+               XR = VR( I )
+               XI = VI( I )
+               IF( RIGHTV ) THEN
+                  DO 220 J = I + 1, N
+                     XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
+                     XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
+  220             CONTINUE
+               ELSE
+                  DO 230 J = 1, I - 1
+                     XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
+                     XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
+  230             CONTINUE
+               END IF
+*
+               W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
+               IF( W.GT.SMLNUM ) THEN
+                  IF( W.LT.ONE ) THEN
+                     W1 = ABS( XR ) + ABS( XI )
+                     IF( W1.GT.W*BIGNUM ) THEN
+                        REC = ONE / W1
+                        CALL DSCAL( N, REC, VR, 1 )
+                        CALL DSCAL( N, REC, VI, 1 )
+                        XR = VR( I )
+                        XI = VI( I )
+                        SCALE = SCALE*REC
+                        VMAX = VMAX*REC
+                     END IF
+                  END IF
+*
+*                 Divide by diagonal element of B.
+*
+                  CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
+     $                         VI( I ) )
+                  VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
+                  VCRIT = BIGNUM / VMAX
+               ELSE
+                  DO 240 J = 1, N
+                     VR( J ) = ZERO
+                     VI( J ) = ZERO
+  240             CONTINUE
+                  VR( I ) = ONE
+                  VI( I ) = ONE
+                  SCALE = ZERO
+                  VMAX = ONE
+                  VCRIT = BIGNUM
+               END IF
+  250       CONTINUE
+*
+*           Test for sufficient growth in the norm of (VR,VI).
+*
+            VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 )
+            IF( VNORM.GE.GROWTO*SCALE )
+     $         GO TO 280
+*
+*           Choose a new orthogonal starting vector and try again.
+*
+            Y = EPS3 / ( ROOTN+ONE )
+            VR( 1 ) = EPS3
+            VI( 1 ) = ZERO
+*
+            DO 260 I = 2, N
+               VR( I ) = Y
+               VI( I ) = ZERO
+  260       CONTINUE
+            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+  270    CONTINUE
+*
+*        Failure to find eigenvector in N iterations
+*
+         INFO = 1
+*
+  280    CONTINUE
+*
+*        Normalize eigenvector.
+*
+         VNORM = ZERO
+         DO 290 I = 1, N
+            VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
+  290    CONTINUE
+         CALL DSCAL( N, ONE / VNORM, VR, 1 )
+         CALL DSCAL( N, ONE / VNORM, VI, 1 )
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLAEIN
+*
+      END
diff --git a/SRC/dlaev2.f b/SRC/dlaev2.f
new file mode 100644
index 00000000..49402faa
--- /dev/null
+++ b/SRC/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/dlaexc.f b/SRC/dlaexc.f
new file mode 100644
index 00000000..18e7d247
--- /dev/null
+++ b/SRC/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/dlag2.f b/SRC/dlag2.f
new file mode 100644
index 00000000..e754203b
--- /dev/null
+++ b/SRC/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/dlag2s.f b/SRC/dlag2s.f
new file mode 100644
index 00000000..e879987e
--- /dev/null
+++ b/SRC/dlag2s.f
@@ -0,0 +1,87 @@
+      SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO)
+*
+*  -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     ..
+*     .. WARNING: PROTOTYPE ..
+*     This is an LAPACK PROTOTYPE routine which means that the
+*     interface of this routine is likely to be changed in the future
+*     based on community feedback.
+*
+*     .. Scalar Arguments ..
+      INTEGER INFO,LDA,LDSA,M,N
+*     ..
+*     .. Array Arguments ..
+      REAL SA(LDSA,*)
+      DOUBLE PRECISION A(LDA,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE
+*  PRECISION matrix, A.
+*
+*  RMAX is the overflow for the SINGLE PRECISION arithmetic
+*  DLAG2S checks that all the entries of A are between -RMAX and
+*  RMAX. If not the convertion is aborted and a flag is raised.
+*
+*  This is a helper routine so there is no argument checking.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of lines 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)
+*          On entry, the M-by-N coefficient matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  SA      (output) REAL array, dimension (LDSA,N)
+*          On exit, if INFO=0, the M-by-N coefficient matrix SA.
+*
+*  LDSA    (input) INTEGER
+*          The leading dimension of the array SA.  LDSA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          > 0:  if INFO = k, the (i,j) entry of the matrix A has
+*                overflowed when moving from DOUBLE PRECISION to SINGLE
+*                k is given by k = (i-1)*LDA+j
+*
+*  =========
+*
+*     .. Local Scalars ..
+      INTEGER I,J
+      DOUBLE PRECISION RMAX
+*     ..
+*     .. External Functions ..
+      REAL SLAMCH
+      EXTERNAL SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      RMAX = SLAMCH('O')
+      DO 20 J = 1,N
+          DO 30 I = 1,M
+              IF ((A(I,J).LT.-RMAX) .OR. (A(I,J).GT.RMAX)) THEN
+                  INFO = (I-1)*LDA + J
+                  GO TO 10
+              END IF
+              SA(I,J) = A(I,J)
+   30     CONTINUE
+   20 CONTINUE
+   10 CONTINUE
+      RETURN
+*
+*     End of DLAG2S
+*
+      END
diff --git a/SRC/dlags2.f b/SRC/dlags2.f
new file mode 100644
index 00000000..837a58e9
--- /dev/null
+++ b/SRC/dlags2.f
@@ -0,0 +1,269 @@
+      SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
+     $                   SNV, CSQ, SNQ )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            UPPER
+      DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
+     $                   SNU, SNV
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
+*  that if ( UPPER ) then
+*
+*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
+*                        ( 0  A3 )     ( x  x  )
+*  and
+*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
+*                        ( 0  B3 )     ( x  x  )
+*
+*  or if ( .NOT.UPPER ) then
+*
+*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
+*                        ( A2 A3 )     ( 0  x  )
+*  and
+*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
+*                        ( B2 B3 )     ( 0  x  )
+*
+*  The rows of the transformed A and B are parallel, where
+*
+*    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
+*        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
+*
+*  Z' denotes the transpose of Z.
+*
+*
+*  Arguments
+*  =========
+*
+*  UPPER   (input) LOGICAL
+*          = .TRUE.: the input matrices A and B are upper triangular.
+*          = .FALSE.: the input matrices A and B are lower triangular.
+*
+*  A1      (input) DOUBLE PRECISION
+*  A2      (input) DOUBLE PRECISION
+*  A3      (input) DOUBLE PRECISION
+*          On entry, A1, A2 and A3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix A.
+*
+*  B1      (input) DOUBLE PRECISION
+*  B2      (input) DOUBLE PRECISION
+*  B3      (input) DOUBLE PRECISION
+*          On entry, B1, B2 and B3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix B.
+*
+*  CSU     (output) DOUBLE PRECISION
+*  SNU     (output) DOUBLE PRECISION
+*          The desired orthogonal matrix U.
+*
+*  CSV     (output) DOUBLE PRECISION
+*  SNV     (output) DOUBLE PRECISION
+*          The desired orthogonal matrix V.
+*
+*  CSQ     (output) DOUBLE PRECISION
+*  SNQ     (output) DOUBLE PRECISION
+*          The desired orthogonal matrix Q.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
+     $                   AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
+     $                   SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
+     $                   VB11, VB11R, VB12, VB21, VB22, VB22R
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARTG, DLASV2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      IF( UPPER ) THEN
+*
+*        Input matrices A and B are upper triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a b )
+*                                   ( 0 d )
+*
+         A = A1*B3
+         D = A3*B1
+         B = A2*B1 - A1*B2
+*
+*        The SVD of real 2-by-2 triangular C
+*
+*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
+     $        THEN
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11R = CSL*A1
+            UA12 = CSL*A2 + SNL*A3
+*
+            VB11R = CSR*B1
+            VB12 = CSR*B2 + SNR*B3
+*
+            AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
+            AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
+*
+*           zero (1,2) elements of U'*A and V'*B
+*
+            IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
+               IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
+     $             ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
+                  CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R )
+               ELSE
+                  CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
+            END IF
+*
+            CSU = CSL
+            SNU = -SNL
+            CSV = CSR
+            SNV = -SNR
+*
+         ELSE
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -SNL*A1
+            UA22 = -SNL*A2 + CSL*A3
+*
+            VB21 = -SNR*B1
+            VB22 = -SNR*B2 + CSR*B3
+*
+            AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
+            AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
+*
+*           zero (2,2) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
+               IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
+     $             ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
+                  CALL DLARTG( -UA21, UA22, CSQ, SNQ, R )
+               ELSE
+                  CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNL
+            SNU = CSL
+            CSV = SNR
+            SNV = CSR
+*
+         END IF
+*
+      ELSE
+*
+*        Input matrices A and B are lower triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a 0 )
+*                                   ( c d )
+*
+         A = A1*B3
+         D = A3*B1
+         C = A2*B3 - A3*B2
+*
+*        The SVD of real 2-by-2 triangular C
+*
+*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
+     $        THEN
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -SNR*A1 + CSR*A2
+            UA22R = CSR*A3
+*
+            VB21 = -SNL*B1 + CSL*B2
+            VB22R = CSL*B3
+*
+            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
+            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
+*
+*           zero (2,1) elements of U'*A and V'*B.
+*
+            IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
+               IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
+     $             ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
+                  CALL DLARTG( UA22R, UA21, CSQ, SNQ, R )
+               ELSE
+                  CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
+            END IF
+*
+            CSU = CSR
+            SNU = -SNR
+            CSV = CSL
+            SNV = -SNL
+*
+         ELSE
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11 = CSR*A1 + SNR*A2
+            UA12 = SNR*A3
+*
+            VB11 = CSL*B1 + SNL*B2
+            VB12 = SNL*B3
+*
+            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
+            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
+*
+*           zero (1,1) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
+               IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
+     $             ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
+                  CALL DLARTG( UA12, UA11, CSQ, SNQ, R )
+               ELSE
+                  CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNR
+            SNU = CSR
+            CSV = SNL
+            SNV = CSL
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLAGS2
+*
+      END
diff --git a/SRC/dlagtf.f b/SRC/dlagtf.f
new file mode 100644
index 00000000..e91357bf
--- /dev/null
+++ b/SRC/dlagtf.f
@@ -0,0 +1,190 @@
+      SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+      DOUBLE PRECISION   LAMBDA, TOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IN( * )
+      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
+*  tridiagonal matrix and lambda is a scalar, as
+*
+*     T - lambda*I = PLU,
+*
+*  where P is a permutation matrix, L is a unit lower tridiagonal matrix
+*  with at most one non-zero sub-diagonal elements per column and U is
+*  an upper triangular matrix with at most two non-zero super-diagonal
+*  elements per column.
+*
+*  The factorization is obtained by Gaussian elimination with partial
+*  pivoting and implicit row scaling.
+*
+*  The parameter LAMBDA is included in the routine so that DLAGTF may
+*  be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
+*  inverse iteration.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix T.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, A must contain the diagonal elements of T.
+*
+*          On exit, A is overwritten by the n diagonal elements of the
+*          upper triangular matrix U of the factorization of T.
+*
+*  LAMBDA  (input) DOUBLE PRECISION
+*          On entry, the scalar lambda.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, B must contain the (n-1) super-diagonal elements of
+*          T.
+*
+*          On exit, B is overwritten by the (n-1) super-diagonal
+*          elements of the matrix U of the factorization of T.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, C must contain the (n-1) sub-diagonal elements of
+*          T.
+*
+*          On exit, C is overwritten by the (n-1) sub-diagonal elements
+*          of the matrix L of the factorization of T.
+*
+*  TOL     (input) DOUBLE PRECISION
+*          On entry, a relative tolerance used to indicate whether or
+*          not the matrix (T - lambda*I) is nearly singular. TOL should
+*          normally be chose as approximately the largest relative error
+*          in the elements of T. For example, if the elements of T are
+*          correct to about 4 significant figures, then TOL should be
+*          set to about 5*10**(-4). If TOL is supplied as less than eps,
+*          where eps is the relative machine precision, then the value
+*          eps is used in place of TOL.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N-2)
+*          On exit, D is overwritten by the (n-2) second super-diagonal
+*          elements of the matrix U of the factorization of T.
+*
+*  IN      (output) INTEGER array, dimension (N)
+*          On exit, IN contains details of the permutation matrix P. If
+*          an interchange occurred at the kth step of the elimination,
+*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
+*          returns the smallest positive integer j such that
+*
+*             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
+*
+*          where norm( A(j) ) denotes the sum of the absolute values of
+*          the jth row of the matrix A. If no such j exists then IN(n)
+*          is returned as zero. If IN(n) is returned as positive, then a
+*          diagonal element of U is small, indicating that
+*          (T - lambda*I) is singular or nearly singular,
+*
+*  INFO    (output) INTEGER
+*          = 0   : successful exit
+*          .lt. 0: if INFO = -k, the kth argument had an illegal value
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            K
+      DOUBLE PRECISION   EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'DLAGTF', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      A( 1 ) = A( 1 ) - LAMBDA
+      IN( N ) = 0
+      IF( N.EQ.1 ) THEN
+         IF( A( 1 ).EQ.ZERO )
+     $      IN( 1 ) = 1
+         RETURN
+      END IF
+*
+      EPS = DLAMCH( 'Epsilon' )
+*
+      TL = MAX( TOL, EPS )
+      SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
+      DO 10 K = 1, N - 1
+         A( K+1 ) = A( K+1 ) - LAMBDA
+         SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
+         IF( K.LT.( N-1 ) )
+     $      SCALE2 = SCALE2 + ABS( B( K+1 ) )
+         IF( A( K ).EQ.ZERO ) THEN
+            PIV1 = ZERO
+         ELSE
+            PIV1 = ABS( A( K ) ) / SCALE1
+         END IF
+         IF( C( K ).EQ.ZERO ) THEN
+            IN( K ) = 0
+            PIV2 = ZERO
+            SCALE1 = SCALE2
+            IF( K.LT.( N-1 ) )
+     $         D( K ) = ZERO
+         ELSE
+            PIV2 = ABS( C( K ) ) / SCALE2
+            IF( PIV2.LE.PIV1 ) THEN
+               IN( K ) = 0
+               SCALE1 = SCALE2
+               C( K ) = C( K ) / A( K )
+               A( K+1 ) = A( K+1 ) - C( K )*B( K )
+               IF( K.LT.( N-1 ) )
+     $            D( K ) = ZERO
+            ELSE
+               IN( K ) = 1
+               MULT = A( K ) / C( K )
+               A( K ) = C( K )
+               TEMP = A( K+1 )
+               A( K+1 ) = B( K ) - MULT*TEMP
+               IF( K.LT.( N-1 ) ) THEN
+                  D( K ) = B( K+1 )
+                  B( K+1 ) = -MULT*D( K )
+               END IF
+               B( K ) = TEMP
+               C( K ) = MULT
+            END IF
+         END IF
+         IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
+     $      IN( N ) = K
+   10 CONTINUE
+      IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
+     $   IN( N ) = N
+*
+      RETURN
+*
+*     End of DLAGTF
+*
+      END
diff --git a/SRC/dlagtm.f b/SRC/dlagtm.f
new file mode 100644
index 00000000..1d13efc2
--- /dev/null
+++ b/SRC/dlagtm.f
@@ -0,0 +1,190 @@
+      SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
+     $                   B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            LDB, LDX, N, NRHS
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAGTM performs a matrix-vector product of the form
+*
+*     B := alpha * A * X + beta * B
+*
+*  where A is a tridiagonal matrix of order N, B and X are N by NRHS
+*  matrices, and alpha and beta are real scalars, each of which may be
+*  0., 1., or -1.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the operation applied to A.
+*          = 'N':  No transpose, B := alpha * A * X + beta * B
+*          = 'T':  Transpose,    B := alpha * A'* X + beta * B
+*          = 'C':  Conjugate transpose = Transpose
+*
+*  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 X and B.
+*
+*  ALPHA   (input) DOUBLE PRECISION
+*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 0.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of T.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of T.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) super-diagonal elements of T.
+*
+*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*          The N by NRHS matrix X.
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(N,1).
+*
+*  BETA    (input) DOUBLE PRECISION
+*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 1.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the N by NRHS matrix B.
+*          On exit, B is overwritten by the matrix expression
+*          B := alpha * A * X + beta * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(N,1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Multiply B by BETA if BETA.NE.1.
+*
+      IF( BETA.EQ.ZERO ) THEN
+         DO 20 J = 1, NRHS
+            DO 10 I = 1, N
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( BETA.EQ.-ONE ) THEN
+         DO 40 J = 1, NRHS
+            DO 30 I = 1, N
+               B( I, J ) = -B( I, J )
+   30       CONTINUE
+   40    CONTINUE
+      END IF
+*
+      IF( ALPHA.EQ.ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B + A*X
+*
+            DO 60 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 50 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DU( I )*X( I+1, J )
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE
+*
+*           Compute B := B + A'*X
+*
+            DO 80 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 70 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DL( I )*X( I+1, J )
+   70             CONTINUE
+               END IF
+   80       CONTINUE
+         END IF
+      ELSE IF( ALPHA.EQ.-ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B - A*X
+*
+            DO 100 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 90 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DU( I )*X( I+1, J )
+   90             CONTINUE
+               END IF
+  100       CONTINUE
+         ELSE
+*
+*           Compute B := B - A'*X
+*
+            DO 120 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 110 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DL( I )*X( I+1, J )
+  110             CONTINUE
+               END IF
+  120       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLAGTM
+*
+      END
diff --git a/SRC/dlagts.f b/SRC/dlagts.f
new file mode 100644
index 00000000..2606e23a
--- /dev/null
+++ b/SRC/dlagts.f
@@ -0,0 +1,304 @@
+      SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, JOB, N
+      DOUBLE PRECISION   TOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IN( * )
+      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAGTS may be used to solve one of the systems of equations
+*
+*     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y,
+*
+*  where T is an n by n tridiagonal matrix, for x, following the
+*  factorization of (T - lambda*I) as
+*
+*     (T - lambda*I) = P*L*U ,
+*
+*  by routine DLAGTF. The choice of equation to be solved is
+*  controlled by the argument JOB, and in each case there is an option
+*  to perturb zero or very small diagonal elements of U, this option
+*  being intended for use in applications such as inverse iteration.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) INTEGER
+*          Specifies the job to be performed by DLAGTS as follows:
+*          =  1: The equations  (T - lambda*I)x = y  are to be solved,
+*                but diagonal elements of U are not to be perturbed.
+*          = -1: The equations  (T - lambda*I)x = y  are to be solved
+*                and, if overflow would otherwise occur, the diagonal
+*                elements of U are to be perturbed. See argument TOL
+*                below.
+*          =  2: The equations  (T - lambda*I)'x = y  are to be solved,
+*                but diagonal elements of U are not to be perturbed.
+*          = -2: The equations  (T - lambda*I)'x = y  are to be solved
+*                and, if overflow would otherwise occur, the diagonal
+*                elements of U are to be perturbed. See argument TOL
+*                below.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (N)
+*          On entry, A must contain the diagonal elements of U as
+*          returned from DLAGTF.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, B must contain the first super-diagonal elements of
+*          U as returned from DLAGTF.
+*
+*  C       (input) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, C must contain the sub-diagonal elements of L as
+*          returned from DLAGTF.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N-2)
+*          On entry, D must contain the second super-diagonal elements
+*          of U as returned from DLAGTF.
+*
+*  IN      (input) INTEGER array, dimension (N)
+*          On entry, IN must contain details of the matrix P as returned
+*          from DLAGTF.
+*
+*  Y       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the right hand side vector y.
+*          On exit, Y is overwritten by the solution vector x.
+*
+*  TOL     (input/output) DOUBLE PRECISION
+*          On entry, with  JOB .lt. 0, TOL should be the minimum
+*          perturbation to be made to very small diagonal elements of U.
+*          TOL should normally be chosen as about eps*norm(U), where eps
+*          is the relative machine precision, but if TOL is supplied as
+*          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
+*          If  JOB .gt. 0  then TOL is not referenced.
+*
+*          On exit, TOL is changed as described above, only if TOL is
+*          non-positive on entry. Otherwise TOL is unchanged.
+*
+*  INFO    (output) INTEGER
+*          = 0   : successful exit
+*          .lt. 0: if INFO = -i, the i-th argument had an illegal value
+*          .gt. 0: overflow would occur when computing the INFO(th)
+*                  element of the solution vector x. This can only occur
+*                  when JOB is supplied as positive and either means
+*                  that a diagonal element of U is very small, or that
+*                  the elements of the right-hand side vector y are very
+*                  large.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            K
+      DOUBLE PRECISION   ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SIGN
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAGTS', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      EPS = DLAMCH( 'Epsilon' )
+      SFMIN = DLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SFMIN
+*
+      IF( JOB.LT.0 ) THEN
+         IF( TOL.LE.ZERO ) THEN
+            TOL = ABS( A( 1 ) )
+            IF( N.GT.1 )
+     $         TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
+            DO 10 K = 3, N
+               TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
+     $               ABS( D( K-2 ) ) )
+   10       CONTINUE
+            TOL = TOL*EPS
+            IF( TOL.EQ.ZERO )
+     $         TOL = EPS
+         END IF
+      END IF
+*
+      IF( ABS( JOB ).EQ.1 ) THEN
+         DO 20 K = 2, N
+            IF( IN( K-1 ).EQ.0 ) THEN
+               Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
+            ELSE
+               TEMP = Y( K-1 )
+               Y( K-1 ) = Y( K )
+               Y( K ) = TEMP - C( K-1 )*Y( K )
+            END IF
+   20    CONTINUE
+         IF( JOB.EQ.1 ) THEN
+            DO 30 K = N, 1, -1
+               IF( K.LE.N-2 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+               ELSE IF( K.EQ.N-1 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        INFO = K
+                        RETURN
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     INFO = K
+                     RETURN
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   30       CONTINUE
+         ELSE
+            DO 50 K = N, 1, -1
+               IF( K.LE.N-2 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+               ELSE IF( K.EQ.N-1 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               PERT = SIGN( TOL, AK )
+   40          CONTINUE
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        AK = AK + PERT
+                        PERT = 2*PERT
+                        GO TO 40
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     AK = AK + PERT
+                     PERT = 2*PERT
+                     GO TO 40
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   50       CONTINUE
+         END IF
+      ELSE
+*
+*        Come to here if  JOB = 2 or -2
+*
+         IF( JOB.EQ.2 ) THEN
+            DO 60 K = 1, N
+               IF( K.GE.3 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+               ELSE IF( K.EQ.2 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        INFO = K
+                        RETURN
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     INFO = K
+                     RETURN
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   60       CONTINUE
+         ELSE
+            DO 80 K = 1, N
+               IF( K.GE.3 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+               ELSE IF( K.EQ.2 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               PERT = SIGN( TOL, AK )
+   70          CONTINUE
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        AK = AK + PERT
+                        PERT = 2*PERT
+                        GO TO 70
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     AK = AK + PERT
+                     PERT = 2*PERT
+                     GO TO 70
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   80       CONTINUE
+         END IF
+*
+         DO 90 K = N, 2, -1
+            IF( IN( K-1 ).EQ.0 ) THEN
+               Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
+            ELSE
+               TEMP = Y( K-1 )
+               Y( K-1 ) = Y( K )
+               Y( K ) = TEMP - C( K-1 )*Y( K )
+            END IF
+   90    CONTINUE
+      END IF
+*
+*     End of DLAGTS
+*
+      END
diff --git a/SRC/dlagv2.f b/SRC/dlagv2.f
new file mode 100644
index 00000000..15bcb0b9
--- /dev/null
+++ b/SRC/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/dlahqr.f b/SRC/dlahqr.f
new file mode 100644
index 00000000..449a3770
--- /dev/null
+++ b/SRC/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/dlahr2.f b/SRC/dlahr2.f
new file mode 100644
index 00000000..6af74977
--- /dev/null
+++ b/SRC/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/dlahrd.f b/SRC/dlahrd.f
new file mode 100644
index 00000000..a04133d1
--- /dev/null
+++ b/SRC/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/dlaic1.f b/SRC/dlaic1.f
new file mode 100644
index 00000000..44baece1
--- /dev/null
+++ b/SRC/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/dlaisnan.f b/SRC/dlaisnan.f
new file mode 100644
index 00000000..6a6c7a91
--- /dev/null
+++ b/SRC/dlaisnan.f
@@ -0,0 +1,40 @@
+      FUNCTION DLAISNAN( DIN1, DIN2 )
+      LOGICAL DLAISNAN
+*
+*  -- 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.
+*
+*  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)
+      END FUNCTION
diff --git a/SRC/dlaln2.f b/SRC/dlaln2.f
new file mode 100644
index 00000000..7c99bdbe
--- /dev/null
+++ b/SRC/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/dlals0.f b/SRC/dlals0.f
new file mode 100644
index 00000000..ed810237
--- /dev/null
+++ b/SRC/dlals0.f
@@ -0,0 +1,377 @@
+      SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
+     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
+     $                   POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
+     $                   LDGNUM, NL, NR, NRHS, SQRE
+      DOUBLE PRECISION   C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
+      DOUBLE PRECISION   B( LDB, * ), BX( LDBX, * ), DIFL( * ),
+     $                   DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
+     $                   POLES( LDGNUM, * ), WORK( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLALS0 applies back the multiplying factors of either the left or the
+*  right singular vector matrix of a diagonal matrix appended by a row
+*  to the right hand side matrix B in solving the least squares problem
+*  using the divide-and-conquer SVD approach.
+*
+*  For the left singular vector matrix, three types of orthogonal
+*  matrices are involved:
+*
+*  (1L) Givens rotations: the number of such rotations is GIVPTR; the
+*       pairs of columns/rows they were applied to are stored in GIVCOL;
+*       and the C- and S-values of these rotations are stored in GIVNUM.
+*
+*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
+*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the
+*       J-th row.
+*
+*  (3L) The left singular vector matrix of the remaining matrix.
+*
+*  For the right singular vector matrix, four types of orthogonal
+*  matrices are involved:
+*
+*  (1R) The right singular vector matrix of the remaining matrix.
+*
+*  (2R) If SQRE = 1, one extra Givens rotation to generate the right
+*       null space.
+*
+*  (3R) The inverse transformation of (2L).
+*
+*  (4R) The inverse transformation of (1L).
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed in
+*         factored form:
+*         = 0: Left singular vector matrix.
+*         = 1: Right singular vector matrix.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block. NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block. NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M. On output, B contains
+*         the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B. LDB must be at least
+*         max(1,MAX( M, N ) ).
+*
+*  BX     (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  PERM   (input) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) applied
+*         to the two blocks.
+*
+*  GIVPTR (input) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of rows/columns
+*         involved in a Givens rotation.
+*
+*  LDGCOL (input) INTEGER
+*         The leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value used in the
+*         corresponding Givens rotation.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of arrays DIFR, POLES and
+*         GIVNUM, must be at least K.
+*
+*  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         On entry, POLES(1:K, 1) contains the new singular
+*         values obtained from solving the secular equation, and
+*         POLES(1:K, 2) is an array containing the poles in the secular
+*         equation.
+*
+*  DIFL   (input) DOUBLE PRECISION array, dimension ( K ).
+*         On entry, DIFL(I) is the distance between I-th updated
+*         (undeflated) singular value and the I-th (undeflated) old
+*         singular value.
+*
+*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
+*         On entry, DIFR(I, 1) contains the distances between I-th
+*         updated (undeflated) singular value and the I+1-th
+*         (undeflated) old singular value. And DIFR(I, 2) is the
+*         normalizing factor for the I-th right singular vector.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( K )
+*         Contain the components of the deflation-adjusted updating row
+*         vector.
+*
+*  K      (input) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  C      (input) DOUBLE PRECISION
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (input) DOUBLE PRECISION
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension ( K )
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, M, N, NLP1
+      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3, DNRM2
+      EXTERNAL           DLAMC3, DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      END IF
+*
+      N = NL + NR + 1
+*
+      IF( NRHS.LT.1 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -7
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -9
+      ELSE IF( GIVPTR.LT.0 ) THEN
+         INFO = -11
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -13
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -15
+      ELSE IF( K.LT.1 ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLALS0', -INFO )
+         RETURN
+      END IF
+*
+      M = N + SQRE
+      NLP1 = NL + 1
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+*
+*        Apply back orthogonal transformations from the left.
+*
+*        Step (1L): apply back the Givens rotations performed.
+*
+         DO 10 I = 1, GIVPTR
+            CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                 GIVNUM( I, 1 ) )
+   10    CONTINUE
+*
+*        Step (2L): permute rows of B.
+*
+         CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
+         DO 20 I = 2, N
+            CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
+   20    CONTINUE
+*
+*        Step (3L): apply the inverse of the left singular vector
+*        matrix to BX.
+*
+         IF( K.EQ.1 ) THEN
+            CALL DCOPY( NRHS, BX, LDBX, B, LDB )
+            IF( Z( 1 ).LT.ZERO ) THEN
+               CALL DSCAL( NRHS, NEGONE, B, LDB )
+            END IF
+         ELSE
+            DO 50 J = 1, K
+               DIFLJ = DIFL( J )
+               DJ = POLES( J, 1 )
+               DSIGJ = -POLES( J, 2 )
+               IF( J.LT.K ) THEN
+                  DIFRJ = -DIFR( J, 1 )
+                  DSIGJP = -POLES( J+1, 2 )
+               END IF
+               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
+     $              THEN
+                  WORK( J ) = ZERO
+               ELSE
+                  WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
+     $                        ( POLES( J, 2 )+DJ )
+               END IF
+               DO 30 I = 1, J - 1
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                           ( DLAMC3( POLES( I, 2 ), DSIGJ )-
+     $                           DIFLJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   30          CONTINUE
+               DO 40 I = J + 1, K
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                           ( DLAMC3( POLES( I, 2 ), DSIGJP )+
+     $                           DIFRJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   40          CONTINUE
+               WORK( 1 ) = NEGONE
+               TEMP = DNRM2( K, WORK, 1 )
+               CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
+     $                     B( J, 1 ), LDB )
+               CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
+     $                      LDB, INFO )
+   50       CONTINUE
+         END IF
+*
+*        Move the deflated rows of BX to B also.
+*
+         IF( K.LT.MAX( M, N ) )
+     $      CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
+     $                   B( K+1, 1 ), LDB )
+      ELSE
+*
+*        Apply back the right orthogonal transformations.
+*
+*        Step (1R): apply back the new right singular vector matrix
+*        to B.
+*
+         IF( K.EQ.1 ) THEN
+            CALL DCOPY( NRHS, B, LDB, BX, LDBX )
+         ELSE
+            DO 80 J = 1, K
+               DSIGJ = POLES( J, 2 )
+               IF( Z( J ).EQ.ZERO ) THEN
+                  WORK( J ) = ZERO
+               ELSE
+                  WORK( J ) = -Z( J ) / DIFL( J ) /
+     $                        ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
+               END IF
+               DO 60 I = 1, J - 1
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
+     $                           2 ) )-DIFR( I, 1 ) ) /
+     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+   60          CONTINUE
+               DO 70 I = J + 1, K
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
+     $                           2 ) )-DIFL( I ) ) /
+     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+   70          CONTINUE
+               CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
+     $                     BX( J, 1 ), LDBX )
+   80       CONTINUE
+         END IF
+*
+*        Step (2R): if SQRE = 1, apply back the rotation that is
+*        related to the right null space of the subproblem.
+*
+         IF( SQRE.EQ.1 ) THEN
+            CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
+            CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
+         END IF
+         IF( K.LT.MAX( M, N ) )
+     $      CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
+     $                   LDBX )
+*
+*        Step (3R): permute rows of B.
+*
+         CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
+         IF( SQRE.EQ.1 ) THEN
+            CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
+         END IF
+         DO 90 I = 2, N
+            CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
+   90    CONTINUE
+*
+*        Step (4R): apply back the Givens rotations performed.
+*
+         DO 100 I = GIVPTR, 1, -1
+            CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                 -GIVNUM( I, 1 ) )
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DLALS0
+*
+      END
diff --git a/SRC/dlalsa.f b/SRC/dlalsa.f
new file mode 100644
index 00000000..418320ef
--- /dev/null
+++ b/SRC/dlalsa.f
@@ -0,0 +1,362 @@
+      SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
+     $                   LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
+     $                   GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
+     $                   SMLSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+     $                   K( * ), PERM( LDGCOL, * )
+      DOUBLE PRECISION   B( LDB, * ), BX( LDBX, * ), C( * ),
+     $                   DIFL( LDU, * ), DIFR( LDU, * ),
+     $                   GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
+     $                   U( LDU, * ), VT( LDU, * ), WORK( * ),
+     $                   Z( LDU, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLALSA is an itermediate step in solving the least squares problem
+*  by computing the SVD of the coefficient matrix in compact form (The
+*  singular vectors are computed as products of simple orthorgonal
+*  matrices.).
+*
+*  If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector
+*  matrix of an upper bidiagonal matrix to the right hand side; and if
+*  ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
+*  right hand side. The singular vector matrices were generated in
+*  compact form by DLALSA.
+*
+*  Arguments
+*  =========
+*
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether the left or the right singular vector
+*         matrix is involved.
+*         = 0: Left singular vector matrix
+*         = 1: Right singular vector matrix
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The row and column dimensions of the upper bidiagonal matrix.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M.
+*         On output, B contains the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,MAX( M, N ) ).
+*
+*  BX     (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
+*         On exit, the result of applying the left or right singular
+*         vector matrix to B.
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
+*         On entry, U contains the left singular vector matrices of all
+*         subproblems at the bottom level.
+*
+*  LDU    (input) INTEGER, LDU = > N.
+*         The leading dimension of arrays U, VT, DIFL, DIFR,
+*         POLES, GIVNUM, and Z.
+*
+*  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
+*         On entry, VT' contains the right singular vector matrices of
+*         all subproblems at the bottom level.
+*
+*  K      (input) INTEGER array, dimension ( N ).
+*
+*  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
+*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
+*
+*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
+*         distances between singular values on the I-th level and
+*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
+*         record the normalizing factors of the right singular vectors
+*         matrices of subproblems on I-th level.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
+*         On entry, Z(1, I) contains the components of the deflation-
+*         adjusted updating row vector for subproblems on the I-th
+*         level.
+*
+*  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
+*         singular values involved in the secular equations on the I-th
+*         level.
+*
+*  GIVPTR (input) INTEGER array, dimension ( N ).
+*         On entry, GIVPTR( I ) records the number of Givens
+*         rotations performed on the I-th problem on the computation
+*         tree.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
+*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
+*         locations of Givens rotations performed on the I-th level on
+*         the computation tree.
+*
+*  LDGCOL (input) INTEGER, LDGCOL = > N.
+*         The leading dimension of arrays GIVCOL and PERM.
+*
+*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).
+*         On entry, PERM(*, I) records permutations done on the I-th
+*         level of the computation tree.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
+*         values of Givens rotations performed on the I-th level on the
+*         computation tree.
+*
+*  C      (input) DOUBLE PRECISION array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         C( I ) contains the C-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  S      (input) DOUBLE PRECISION array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         S( I ) contains the S-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  WORK   (workspace) DOUBLE PRECISION array.
+*         The dimension must be at least N.
+*
+*  IWORK  (workspace) INTEGER array.
+*         The dimension must be at least 3 * 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
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
+     $                   ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
+     $                   NR, NRF, NRP1, SQRE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DLALS0, DLASDT, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.SMLSIZ ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -6
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -8
+      ELSE IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -19
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLALSA', -INFO )
+         RETURN
+      END IF
+*
+*     Book-keeping and  setting up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+*
+      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     The following code applies back the left singular vector factors.
+*     For applying back the right singular vector factors, go to 50.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         GO TO 50
+      END IF
+*
+*     The nodes on the bottom level of the tree were solved
+*     by DLASDQ. The corresponding left and right singular vector
+*     matrices are in explicit form. First apply back the left
+*     singular vector matrices.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 10 I = NDB1, ND
+*
+*        IC : center row of each node
+*        NL : number of rows of left  subproblem
+*        NR : number of rows of right subproblem
+*        NLF: starting row of the left   subproblem
+*        NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLF = IC - NL
+         NRF = IC + 1
+         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+     $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+   10 CONTINUE
+*
+*     Next copy the rows of B that correspond to unchanged rows
+*     in the bidiagonal matrix to BX.
+*
+      DO 20 I = 1, ND
+         IC = IWORK( INODE+I-1 )
+         CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
+   20 CONTINUE
+*
+*     Finally go through the left singular vector matrices of all
+*     the other subproblems bottom-up on the tree.
+*
+      J = 2**NLVL
+      SQRE = 0
+*
+      DO 40 LVL = NLVL, 1, -1
+         LVL2 = 2*LVL - 1
+*
+*        find the first node LF and last node LL on
+*        the current level LVL
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 30 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            J = J - 1
+            CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
+     $                   B( NLF, 1 ), LDB, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+     $                   INFO )
+   30    CONTINUE
+   40 CONTINUE
+      GO TO 90
+*
+*     ICOMPQ = 1: applying back the right singular vector factors.
+*
+   50 CONTINUE
+*
+*     First now go through the right singular vector matrices of all
+*     the tree nodes top-down.
+*
+      J = 0
+      DO 70 LVL = 1, NLVL
+         LVL2 = 2*LVL - 1
+*
+*        Find the first node LF and last node LL on
+*        the current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 60 I = LL, LF, -1
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            IF( I.EQ.LL ) THEN
+               SQRE = 0
+            ELSE
+               SQRE = 1
+            END IF
+            J = J + 1
+            CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
+     $                   BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+     $                   INFO )
+   60    CONTINUE
+   70 CONTINUE
+*
+*     The nodes on the bottom level of the tree were solved
+*     by DLASDQ. The corresponding right singular vector
+*     matrices are in explicit form. Apply them back.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 80 I = NDB1, ND
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLP1 = NL + 1
+         IF( I.EQ.ND ) THEN
+            NRP1 = NR
+         ELSE
+            NRP1 = NR + 1
+         END IF
+         NLF = IC - NL
+         NRF = IC + 1
+         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+     $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+   80 CONTINUE
+*
+   90 CONTINUE
+*
+      RETURN
+*
+*     End of DLALSA
+*
+      END
diff --git a/SRC/dlalsd.f b/SRC/dlalsd.f
new file mode 100644
index 00000000..f6a0c8b9
--- /dev/null
+++ b/SRC/dlalsd.f
@@ -0,0 +1,434 @@
+      SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
+     $                   RANK, WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLALSD uses the singular value decomposition of A to solve the least
+*  squares problem of finding X to minimize the Euclidean norm of each
+*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
+*  are N-by-NRHS. The solution X overwrites B.
+*
+*  The singular values of A smaller than RCOND times the largest
+*  singular value are treated as zero in solving the least squares
+*  problem; in this case a minimum norm solution is returned.
+*  The actual singular values are returned in D in ascending order.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  UPLO   (input) CHARACTER*1
+*         = 'U': D and E define an upper bidiagonal matrix.
+*         = 'L': D and E define a  lower bidiagonal matrix.
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The dimension of the  bidiagonal matrix.  N >= 0.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B. NRHS must be at least 1.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix. On exit, if INFO = 0, D contains its singular values.
+*
+*  E      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*         Contains the super-diagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  B      (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*         On input, B contains the right hand sides of the least
+*         squares problem. On output, B contains the solution X.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,N).
+*
+*  RCOND  (input) DOUBLE PRECISION
+*         The singular values of A less than or equal to RCOND times
+*         the largest singular value are treated as zero in solving
+*         the least squares problem. If RCOND is negative,
+*         machine precision is used instead.
+*         For example, if diag(S)*X=B were the least squares problem,
+*         where diag(S) is a diagonal matrix of singular values, the
+*         solution would be X(i) = B(i) / S(i) if S(i) is greater than
+*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
+*         RCOND*max(S).
+*
+*  RANK   (output) INTEGER
+*         The number of singular values of A greater than RCOND times
+*         the largest singular value.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension at least
+*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
+*         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
+*
+*  IWORK  (workspace) INTEGER array, dimension at least
+*         (3*N*NLVL + 11*N)
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*         > 0:  The algorithm failed to compute an singular value while
+*               working on the submatrix lying in rows and columns
+*               INFO/(N+1) through MOD(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
+     $                   GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
+     $                   NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
+     $                   SMLSZP, SQRE, ST, ST1, U, VT, Z
+      DOUBLE PRECISION   CS, EPS, ORGNRM, R, RCND, SN, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           IDAMAX, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL,
+     $                   DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLALSD', -INFO )
+         RETURN
+      END IF
+*
+      EPS = DLAMCH( 'Epsilon' )
+*
+*     Set up the tolerance.
+*
+      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
+         RCND = EPS
+      ELSE
+         RCND = RCOND
+      END IF
+*
+      RANK = 0
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         IF( D( 1 ).EQ.ZERO ) THEN
+            CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
+         ELSE
+            RANK = 1
+            CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
+            D( 1 ) = ABS( D( 1 ) )
+         END IF
+         RETURN
+      END IF
+*
+*     Rotate the matrix if it is lower bidiagonal.
+*
+      IF( UPLO.EQ.'L' ) THEN
+         DO 10 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( NRHS.EQ.1 ) THEN
+               CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
+            ELSE
+               WORK( I*2-1 ) = CS
+               WORK( I*2 ) = SN
+            END IF
+   10    CONTINUE
+         IF( NRHS.GT.1 ) THEN
+            DO 30 I = 1, NRHS
+               DO 20 J = 1, N - 1
+                  CS = WORK( J*2-1 )
+                  SN = WORK( J*2 )
+                  CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
+   20          CONTINUE
+   30       CONTINUE
+         END IF
+      END IF
+*
+*     Scale.
+*
+      NM1 = N - 1
+      ORGNRM = DLANST( 'M', N, D, E )
+      IF( ORGNRM.EQ.ZERO ) THEN
+         CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
+         RETURN
+      END IF
+*
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
+*
+*     If N is smaller than the minimum divide size SMLSIZ, then solve
+*     the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         NWORK = 1 + N*N
+         CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N )
+         CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
+     $                LDB, WORK( NWORK ), INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
+         DO 40 I = 1, N
+            IF( D( I ).LE.TOL ) THEN
+               CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+            ELSE
+               CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
+     $                      LDB, INFO )
+               RANK = RANK + 1
+            END IF
+   40    CONTINUE
+         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
+     $               WORK( NWORK ), N )
+         CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
+*
+*        Unscale.
+*
+         CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+         CALL DLASRT( 'D', N, D, INFO )
+         CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+         RETURN
+      END IF
+*
+*     Book-keeping and setting up some constants.
+*
+      NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+*
+      SMLSZP = SMLSIZ + 1
+*
+      U = 1
+      VT = 1 + SMLSIZ*N
+      DIFL = VT + SMLSZP*N
+      DIFR = DIFL + NLVL*N
+      Z = DIFR + NLVL*N*2
+      C = Z + NLVL*N
+      S = C + N
+      POLES = S + N
+      GIVNUM = POLES + 2*NLVL*N
+      BX = GIVNUM + 2*NLVL*N
+      NWORK = BX + N*NRHS
+*
+      SIZEI = 1 + N
+      K = SIZEI + N
+      GIVPTR = K + N
+      PERM = GIVPTR + N
+      GIVCOL = PERM + NLVL*N
+      IWK = GIVCOL + NLVL*N*2
+*
+      ST = 1
+      SQRE = 0
+      ICMPQ1 = 1
+      ICMPQ2 = 0
+      NSUB = 0
+*
+      DO 50 I = 1, N
+         IF( ABS( D( I ) ).LT.EPS ) THEN
+            D( I ) = SIGN( EPS, D( I ) )
+         END IF
+   50 CONTINUE
+*
+      DO 60 I = 1, NM1
+         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+            NSUB = NSUB + 1
+            IWORK( NSUB ) = ST
+*
+*           Subproblem found. First determine its size and then
+*           apply divide and conquer on it.
+*
+            IF( I.LT.NM1 ) THEN
+*
+*              A subproblem with E(I) small for I < NM1.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+*              A subproblem with E(NM1) not too small but I = NM1.
+*
+               NSIZE = N - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE
+*
+*              A subproblem with E(NM1) small. This implies an
+*              1-by-1 subproblem at D(N), which is not solved
+*              explicitly.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+               NSUB = NSUB + 1
+               IWORK( NSUB ) = N
+               IWORK( SIZEI+NSUB-1 ) = 1
+               CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
+            END IF
+            ST1 = ST - 1
+            IF( NSIZE.EQ.1 ) THEN
+*
+*              This is a 1-by-1 subproblem and is not solved
+*              explicitly.
+*
+               CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
+            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+*              This is a small subproblem and is solved by DLASDQ.
+*
+               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+     $                      WORK( VT+ST1 ), N )
+               CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
+     $                      E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
+     $                      N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+               CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
+     $                      WORK( BX+ST1 ), N )
+            ELSE
+*
+*              A large problem. Solve it using divide and conquer.
+*
+               CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
+     $                      E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
+     $                      IWORK( K+ST1 ), WORK( DIFL+ST1 ),
+     $                      WORK( DIFR+ST1 ), WORK( Z+ST1 ),
+     $                      WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
+     $                      IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
+     $                      WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
+     $                      WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
+     $                      INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+               BXST = BX + ST1
+               CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
+     $                      LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
+     $                      WORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                      WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+     $                      WORK( Z+ST1 ), WORK( POLES+ST1 ),
+     $                      IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                      IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+     $                      WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+     $                      IWORK( IWK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+            END IF
+            ST = I + 1
+         END IF
+   60 CONTINUE
+*
+*     Apply the singular values and treat the tiny ones as zero.
+*
+      TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
+*
+      DO 70 I = 1, N
+*
+*        Some of the elements in D can be negative because 1-by-1
+*        subproblems were not solved explicitly.
+*
+         IF( ABS( D( I ) ).LE.TOL ) THEN
+            CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
+         ELSE
+            RANK = RANK + 1
+            CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
+     $                   WORK( BX+I-1 ), N, INFO )
+         END IF
+         D( I ) = ABS( D( I ) )
+   70 CONTINUE
+*
+*     Now apply back the right singular vectors.
+*
+      ICMPQ2 = 1
+      DO 80 I = 1, NSUB
+         ST = IWORK( I )
+         ST1 = ST - 1
+         NSIZE = IWORK( SIZEI+I-1 )
+         BXST = BX + ST1
+         IF( NSIZE.EQ.1 ) THEN
+            CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
+         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                  WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
+     $                  B( ST, 1 ), LDB )
+         ELSE
+            CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
+     $                   B( ST, 1 ), LDB, WORK( U+ST1 ), N,
+     $                   WORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                   WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+     $                   WORK( Z+ST1 ), WORK( POLES+ST1 ),
+     $                   IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                   IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+     $                   WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+     $                   IWORK( IWK ), INFO )
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+         END IF
+   80 CONTINUE
+*
+*     Unscale and sort the singular values.
+*
+      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+      CALL DLASRT( 'D', N, D, INFO )
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+      RETURN
+*
+*     End of DLALSD
+*
+      END
diff --git a/SRC/dlamrg.f b/SRC/dlamrg.f
new file mode 100644
index 00000000..db2bd4b3
--- /dev/null
+++ b/SRC/dlamrg.f
@@ -0,0 +1,103 @@
+      SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            DTRD1, DTRD2, N1, N2
+*     ..
+*     .. Array Arguments ..
+      INTEGER            INDEX( * )
+      DOUBLE PRECISION   A( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMRG will create a permutation list which will merge the elements
+*  of A (which is composed of two independently sorted sets) into a
+*  single set which is sorted in ascending order.
+*
+*  Arguments
+*  =========
+*
+*  N1     (input) INTEGER
+*  N2     (input) INTEGER
+*         These arguements contain the respective lengths of the two
+*         sorted lists to be merged.
+*
+*  A      (input) DOUBLE PRECISION array, dimension (N1+N2)
+*         The first N1 elements of A contain a list of numbers which
+*         are sorted in either ascending or descending order.  Likewise
+*         for the final N2 elements.
+*
+*  DTRD1  (input) INTEGER
+*  DTRD2  (input) INTEGER
+*         These are the strides to be taken through the array A.
+*         Allowable strides are 1 and -1.  They indicate whether a
+*         subset of A is sorted in ascending (DTRDx = 1) or descending
+*         (DTRDx = -1) order.
+*
+*  INDEX  (output) INTEGER array, dimension (N1+N2)
+*         On exit this array will contain a permutation such that
+*         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
+*         sorted in ascending order.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IND1, IND2, N1SV, N2SV
+*     ..
+*     .. Executable Statements ..
+*
+      N1SV = N1
+      N2SV = N2
+      IF( DTRD1.GT.0 ) THEN
+         IND1 = 1
+      ELSE
+         IND1 = N1
+      END IF
+      IF( DTRD2.GT.0 ) THEN
+         IND2 = 1 + N1
+      ELSE
+         IND2 = N1 + N2
+      END IF
+      I = 1
+*     while ( (N1SV > 0) & (N2SV > 0) )
+   10 CONTINUE
+      IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
+         IF( A( IND1 ).LE.A( IND2 ) ) THEN
+            INDEX( I ) = IND1
+            I = I + 1
+            IND1 = IND1 + DTRD1
+            N1SV = N1SV - 1
+         ELSE
+            INDEX( I ) = IND2
+            I = I + 1
+            IND2 = IND2 + DTRD2
+            N2SV = N2SV - 1
+         END IF
+         GO TO 10
+      END IF
+*     end while
+      IF( N1SV.EQ.0 ) THEN
+         DO 20 N1SV = 1, N2SV
+            INDEX( I ) = IND2
+            I = I + 1
+            IND2 = IND2 + DTRD2
+   20    CONTINUE
+      ELSE
+*     N2SV .EQ. 0
+         DO 30 N2SV = 1, N1SV
+            INDEX( I ) = IND1
+            I = I + 1
+            IND1 = IND1 + DTRD1
+   30    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DLAMRG
+*
+      END
diff --git a/SRC/dlaneg.f b/SRC/dlaneg.f
new file mode 100644
index 00000000..fead657c
--- /dev/null
+++ b/SRC/dlaneg.f
@@ -0,0 +1,164 @@
+      FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )
+      IMPLICIT NONE
+      INTEGER DLANEG
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N, R
+      DOUBLE PRECISION   PIVMIN, SIGMA
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), LLD( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANEG computes the Sturm count, the number of negative pivots
+*  encountered while factoring tridiagonal T - sigma I = L D L^T.
+*  This implementation works directly on the factors without forming
+*  the tridiagonal matrix T.  The Sturm count is also the number of
+*  eigenvalues of T less than sigma.
+*
+*  This routine is called from DLARRB.
+*
+*  The current routine does not use the PIVMIN parameter but rather
+*  requires IEEE-754 propagation of Infinities and NaNs.  This
+*  routine also has no input range restrictions but does require
+*  default exception handling such that x/0 produces Inf when x is
+*  non-zero, and Inf/Inf produces NaN.  For more information, see:
+*
+*    Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
+*    Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
+*    Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624
+*    (Tech report version in LAWN 172 with the same title.)
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D.
+*
+*  LLD     (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (N-1) elements L(i)*L(i)*D(i).
+*
+*  SIGMA   (input) DOUBLE PRECISION
+*          Shift amount in T - sigma I = L D L^T.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence.  May be used
+*          when zero pivots are encountered on non-IEEE-754
+*          architectures.
+*
+*  R       (input) INTEGER
+*          The twist index for the twisted factorization that is used
+*          for the negcount.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*     Jason Riedy, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     Some architectures propagate Infinities and NaNs very slowly, so
+*     the code computes counts in BLKLEN chunks.  Then a NaN can
+*     propagate at most BLKLEN columns before being detected.  This is
+*     not a general tuning parameter; it needs only to be just large
+*     enough that the overhead is tiny in common cases.
+      INTEGER BLKLEN
+      PARAMETER ( BLKLEN = 128 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BJ, J, NEG1, NEG2, NEGCNT
+      DOUBLE PRECISION   BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
+      LOGICAL SAWNAN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MIN, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL DISNAN
+      EXTERNAL DISNAN
+*     ..
+*     .. Executable Statements ..
+
+      NEGCNT = 0
+
+*     I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+      T = -SIGMA
+      DO 210 BJ = 1, R-1, BLKLEN
+         NEG1 = 0
+         BSAV = T
+         DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+            DPLUS = D( J ) + T
+            IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+            TMP = T / DPLUS
+            T = TMP * LLD( J ) - SIGMA
+ 21      CONTINUE
+         SAWNAN = DISNAN( T )
+*     Run a slower version of the above loop if a NaN is detected.
+*     A NaN should occur only with a zero pivot after an infinite
+*     pivot.  In that case, substituting 1 for T/DPLUS is the
+*     correct limit.
+         IF( SAWNAN ) THEN
+            NEG1 = 0
+            T = BSAV
+            DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+               DPLUS = D( J ) + T
+               IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+               TMP = T / DPLUS
+               IF (DISNAN(TMP)) TMP = ONE
+               T = TMP * LLD(J) - SIGMA
+ 22         CONTINUE
+         END IF
+         NEGCNT = NEGCNT + NEG1
+ 210  CONTINUE
+*
+*     II) lower part: L D L^T - SIGMA I = U- D- U-^T
+      P = D( N ) - SIGMA
+      DO 230 BJ = N-1, R, -BLKLEN
+         NEG2 = 0
+         BSAV = P
+         DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+            DMINUS = LLD( J ) + P
+            IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+            TMP = P / DMINUS
+            P = TMP * D( J ) - SIGMA
+ 23      CONTINUE
+         SAWNAN = DISNAN( P )
+*     As above, run a slower version that substitutes 1 for Inf/Inf.
+*
+         IF( SAWNAN ) THEN
+            NEG2 = 0
+            P = BSAV
+            DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+               DMINUS = LLD( J ) + P
+               IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+               TMP = P / DMINUS
+               IF (DISNAN(TMP)) TMP = ONE
+               P = TMP * D(J) - SIGMA
+ 24         CONTINUE
+         END IF
+         NEGCNT = NEGCNT + NEG2
+ 230  CONTINUE
+*
+*     III) Twist index
+*       T was shifted by SIGMA initially.
+      GAMMA = (T + SIGMA) + P
+      IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+      DLANEG = NEGCNT
+      END
diff --git a/SRC/dlangb.f b/SRC/dlangb.f
new file mode 100644
index 00000000..2fea84de
--- /dev/null
+++ b/SRC/dlangb.f
@@ -0,0 +1,154 @@
+      DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB,
+     $                 WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            KL, KU, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANGB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  DLANGB returns the value
+*
+*     DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANGB as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANGB is
+*          set to zero.
+*
+*  KL      (input) INTEGER
+*          The number of sub-diagonals of the matrix A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of super-diagonals of the matrix A.  KU >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+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, K, L
+      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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               VALUE = MAX( VALUE, ABS( AB( 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               SUM = SUM + ABS( AB( 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
+            K = KU + 1 - J
+            DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
+               WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, N
+            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
+            L = MAX( 1, J-KU )
+            K = KU + 1 - J + L
+            CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANGB = VALUE
+      RETURN
+*
+*     End of DLANGB
+*
+      END
diff --git a/SRC/dlange.f b/SRC/dlange.f
new file mode 100644
index 00000000..fec96ac7
--- /dev/null
+++ b/SRC/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/dlangt.f b/SRC/dlangt.f
new file mode 100644
index 00000000..d02ed572
--- /dev/null
+++ b/SRC/dlangt.f
@@ -0,0 +1,141 @@
+      DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )
+*
+*  -- 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( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANGT  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  real tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  DLANGT returns the value
+*
+*     DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANGT as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANGT is
+*          set to zero.
+*
+*  DL      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of A.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) 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( DL( I ) ) )
+            ANORM = MAX( ANORM, ABS( D( I ) ) )
+            ANORM = MAX( ANORM, ABS( DU( I ) ) )
+   10    CONTINUE
+      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
+*
+*        Find norm1(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
+     $              ABS( D( N ) )+ABS( DU( N-1 ) ) )
+            DO 20 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
+     $                 ABS( DU( I-1 ) ) )
+   20       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
+     $              ABS( D( N ) )+ABS( DL( N-1 ) ) )
+            DO 30 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
+     $                 ABS( DL( I-1 ) ) )
+   30       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         CALL DLASSQ( N, D, 1, SCALE, SUM )
+         IF( N.GT.1 ) THEN
+            CALL DLASSQ( N-1, DL, 1, SCALE, SUM )
+            CALL DLASSQ( N-1, DU, 1, SCALE, SUM )
+         END IF
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANGT = ANORM
+      RETURN
+*
+*     End of DLANGT
+*
+      END
diff --git a/SRC/dlanhs.f b/SRC/dlanhs.f
new file mode 100644
index 00000000..76b87eeb
--- /dev/null
+++ b/SRC/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/dlansb.f b/SRC/dlansb.f
new file mode 100644
index 00000000..1404a571
--- /dev/null
+++ b/SRC/dlansb.f
@@ -0,0 +1,186 @@
+      DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB,
+     $                 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANSB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n symmetric band matrix A,  with k super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  DLANSB returns the value
+*
+*     DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANSB as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          band matrix A is supplied.
+*          = 'U':  Upper triangular part is supplied
+*          = 'L':  Lower triangular part is supplied
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANSB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals or sub-diagonals of the
+*          band matrix A.  K >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first K+1 rows of AB.  The j-th column of A is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+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, L
+      DOUBLE PRECISION   ABSA, 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
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = MAX( K+2-J, 1 ), K + 1
+                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               DO 30 I = 1, MIN( N+1-J, K+1 )
+                  VALUE = MAX( VALUE, ABS( AB( 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
+               L = K + 1 - J
+               DO 50 I = MAX( 1, J-K ), J - 1
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( AB( K+1, J ) )
+   60       CONTINUE
+            DO 70 I = 1, N
+               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( AB( 1, J ) )
+               L = 1 - J
+               DO 90 I = J + 1, MIN( N, J+K )
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               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( K.GT.0 ) THEN
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 110 J = 2, N
+                  CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  110          CONTINUE
+               L = K + 1
+            ELSE
+               DO 120 J = 1, N - 1
+                  CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                         SUM )
+  120          CONTINUE
+               L = 1
+            END IF
+            SUM = 2*SUM
+         ELSE
+            L = 1
+         END IF
+         CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANSB = VALUE
+      RETURN
+*
+*     End of DLANSB
+*
+      END
diff --git a/SRC/dlansp.f b/SRC/dlansp.f
new file mode 100644
index 00000000..ab221006
--- /dev/null
+++ b/SRC/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/dlanst.f b/SRC/dlanst.f
new file mode 100644
index 00000000..2b12091a
--- /dev/null
+++ b/SRC/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/dlansy.f b/SRC/dlansy.f
new file mode 100644
index 00000000..b6c727c0
--- /dev/null
+++ b/SRC/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/dlantb.f b/SRC/dlantb.f
new file mode 100644
index 00000000..1c6490e8
--- /dev/null
+++ b/SRC/dlantb.f
@@ -0,0 +1,284 @@
+      DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB,
+     $                 LDAB, 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANTB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.
+*
+*  Description
+*  ===========
+*
+*  DLANTB returns the value
+*
+*     DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANTB as described
+*          above.
+*
+*  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.  When N = 0, DLANTB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.
+*          K >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first k+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*          Note that when DIAG = 'U', the elements of the array AB
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+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 ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, L
+      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))).
+*
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = MAX( K+2-J, 1 ), K
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = 2, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   30             CONTINUE
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = MAX( K+2-J, 1 ), K + 1
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = 1, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( 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 ) THEN
+                  SUM = ONE
+                  DO 90 I = MAX( K+2-J, 1 ), K
+                     SUM = SUM + ABS( AB( I, J ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = MAX( K+2-J, 1 ), K + 1
+                     SUM = SUM + ABS( AB( I, J ) )
+  100             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = 2, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = 1, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  130             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  L = K + 1 - J
+                  DO 160 I = MAX( 1, J-K ), J - 1
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  160             CONTINUE
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  L = K + 1 - J
+                  DO 190 I = MAX( 1, J-K ), J
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  L = 1 - J
+                  DO 220 I = J + 1, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  L = 1 - J
+                  DO 250 I = J, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 280 J = 2, N
+                     CALL DLASSQ( MIN( J-1, K ),
+     $                            AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
+     $                            SUM )
+  280             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 290 J = 1, N
+                  CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 300 J = 1, N - 1
+                     CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                            SUM )
+  300             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 310 J = 1, N
+                  CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANTB = VALUE
+      RETURN
+*
+*     End of DLANTB
+*
+      END
diff --git a/SRC/dlantp.f b/SRC/dlantp.f
new file mode 100644
index 00000000..5a04edad
--- /dev/null
+++ b/SRC/dlantp.f
@@ -0,0 +1,285 @@
+      DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, 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            N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANTP  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  triangular matrix A, supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  DLANTP returns the value
+*
+*     DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANTP as described
+*          above.
+*
+*  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.  When N = 0, DLANTP is
+*          set to zero.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          Note that when DIAG = 'U', the elements of the array AP
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  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 ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, K
+      DOUBLE PRECISION   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))).
+*
+         K = 1
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = K, K + J - 2
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10             CONTINUE
+                  K = K + J
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = K + 1, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   30             CONTINUE
+                  K = K + N - J + 1
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = K, K + J - 1
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   50             CONTINUE
+                  K = K + J
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = K, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   70             CONTINUE
+                  K = K + N - J + 1
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         K = 1
+         UDIAG = LSAME( DIAG, 'U' )
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 90 I = K, K + J - 2
+                     SUM = SUM + ABS( AP( I ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = K, K + J - 1
+                     SUM = SUM + ABS( AP( I ) )
+  100             CONTINUE
+               END IF
+               K = K + J
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = K + 1, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = K, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  130             CONTINUE
+               END IF
+               K = K + N - J + 1
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         K = 1
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  DO 160 I = 1, J - 1
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  160             CONTINUE
+                  K = K + 1
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  DO 190 I = 1, J
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  K = K + 1
+                  DO 220 I = J + 1, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  DO 250 I = J, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         VALUE = ZERO
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 280 J = 2, N
+                  CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  280          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 290 J = 1, N
+                  CALL DLASSQ( J, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 300 J = 1, N - 1
+                  CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  300          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 310 J = 1, N
+                  CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANTP = VALUE
+      RETURN
+*
+*     End of DLANTP
+*
+      END
diff --git a/SRC/dlantr.f b/SRC/dlantr.f
new file mode 100644
index 00000000..92debd3d
--- /dev/null
+++ b/SRC/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/dlanv2.f b/SRC/dlanv2.f
new file mode 100644
index 00000000..cef3f472
--- /dev/null
+++ b/SRC/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/dlapll.f b/SRC/dlapll.f
new file mode 100644
index 00000000..7eb63f28
--- /dev/null
+++ b/SRC/dlapll.f
@@ -0,0 +1,99 @@
+      SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )
+*
+*  -- 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   SSMIN
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given two column vectors X and Y, let
+*
+*                       A = ( X Y ).
+*
+*  The subroutine first computes the QR factorization of A = Q*R,
+*  and then computes the SVD of the 2-by-2 upper triangular matrix R.
+*  The smaller singular value of R is returned in SSMIN, which is used
+*  as the measurement of the linear dependency of the vectors X and Y.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The length of the vectors X and Y.
+*
+*  X       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCX)
+*          On entry, X contains the N-vector X.
+*          On exit, X is overwritten.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive elements of X. INCX > 0.
+*
+*  Y       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCY)
+*          On entry, Y contains the N-vector Y.
+*          On exit, Y is overwritten.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive elements of Y. INCY > 0.
+*
+*  SSMIN   (output) DOUBLE PRECISION
+*          The smallest singular value of the N-by-2 matrix A = ( X Y ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   A11, A12, A22, C, SSMAX, TAU
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DLARFG, DLAS2
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         SSMIN = ZERO
+         RETURN
+      END IF
+*
+*     Compute the QR factorization of the N-by-2 matrix ( X Y )
+*
+      CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
+      A11 = X( 1 )
+      X( 1 ) = ONE
+*
+      C = -TAU*DDOT( N, X, INCX, Y, INCY )
+      CALL DAXPY( N, C, X, INCX, Y, INCY )
+*
+      CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
+*
+      A12 = Y( 1 )
+      A22 = Y( 1+INCY )
+*
+*     Compute the SVD of 2-by-2 Upper triangular matrix.
+*
+      CALL DLAS2( A11, A12, A22, SSMIN, SSMAX )
+*
+      RETURN
+*
+*     End of DLAPLL
+*
+      END
diff --git a/SRC/dlapmt.f b/SRC/dlapmt.f
new file mode 100644
index 00000000..325774c0
--- /dev/null
+++ b/SRC/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/dlapy2.f b/SRC/dlapy2.f
new file mode 100644
index 00000000..98ef81b6
--- /dev/null
+++ b/SRC/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/dlapy3.f b/SRC/dlapy3.f
new file mode 100644
index 00000000..2b47bb47
--- /dev/null
+++ b/SRC/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/dlaqgb.f b/SRC/dlaqgb.f
new file mode 100644
index 00000000..97ffab67
--- /dev/null
+++ b/SRC/dlaqgb.f
@@ -0,0 +1,168 @@
+      SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, 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            KL, KU, LDAB, M, N
+      DOUBLE PRECISION   AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQGB equilibrates a general M by N band matrix A with KL
+*  subdiagonals and KU superdiagonals using the row and scaling factors
+*  in the vectors R and C.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, the equilibrated matrix, in the same storage format
+*          as A.  See EQUED for the form of the equilibrated matrix.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDA >= KL+KU+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
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+     $     THEN
+*
+*        No row scaling
+*
+         IF( COLCND.GE.THRESH ) THEN
+*
+*           No column scaling
+*
+            EQUED = 'N'
+         ELSE
+*
+*           Column scaling
+*
+            DO 20 J = 1, N
+               CJ = C( J )
+               DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
+                  AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+            EQUED = 'C'
+         END IF
+      ELSE IF( COLCND.GE.THRESH ) THEN
+*
+*        Row scaling, no column scaling
+*
+         DO 40 J = 1, N
+            DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
+   30       CONTINUE
+   40    CONTINUE
+         EQUED = 'R'
+      ELSE
+*
+*        Row and column scaling
+*
+         DO 60 J = 1, N
+            CJ = C( J )
+            DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
+   50       CONTINUE
+   60    CONTINUE
+         EQUED = 'B'
+      END IF
+*
+      RETURN
+*
+*     End of DLAQGB
+*
+      END
diff --git a/SRC/dlaqge.f b/SRC/dlaqge.f
new file mode 100644
index 00000000..9feb927c
--- /dev/null
+++ b/SRC/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/dlaqp2.f b/SRC/dlaqp2.f
new file mode 100644
index 00000000..5ed16764
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+     $                   TAU( I ) )
+         ELSE
+            CALL DLARFP( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
+         END IF
+*
+         IF( I.LE.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/dlaqps.f b/SRC/dlaqps.f
new file mode 100644
index 00000000..2af4e0a4
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+         ELSE
+            CALL DLARFP( 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/dlaqr0.f b/SRC/dlaqr0.f
new file mode 100644
index 00000000..479da53d
--- /dev/null
+++ b/SRC/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/dlaqr1.f b/SRC/dlaqr1.f
new file mode 100644
index 00000000..c80fe668
--- /dev/null
+++ b/SRC/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/dlaqr2.f b/SRC/dlaqr2.f
new file mode 100644
index 00000000..6ddb3309
--- /dev/null
+++ b/SRC/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/dlaqr3.f b/SRC/dlaqr3.f
new file mode 100644
index 00000000..877b267a
--- /dev/null
+++ b/SRC/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/dlaqr4.f b/SRC/dlaqr4.f
new file mode 100644
index 00000000..8692e7f9
--- /dev/null
+++ b/SRC/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/dlaqr5.f b/SRC/dlaqr5.f
new file mode 100644
index 00000000..17857572
--- /dev/null
+++ b/SRC/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/dlaqsb.f b/SRC/dlaqsb.f
new file mode 100644
index 00000000..d357bee1
--- /dev/null
+++ b/SRC/dlaqsb.f
@@ -0,0 +1,148 @@
+      SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            KD, LDAB, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQSB equilibrates a symmetric band matrix A using the scaling
+*  factors in the vector S.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored in band format.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = MAX( 1, J-KD ), J
+                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, MIN( N, J+KD )
+                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of DLAQSB
+*
+      END
diff --git a/SRC/dlaqsp.f b/SRC/dlaqsp.f
new file mode 100644
index 00000000..70f34879
--- /dev/null
+++ b/SRC/dlaqsp.f
@@ -0,0 +1,140 @@
+      SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQSP equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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.
+*
+*  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 equilibrated matrix:  diag(S) * A * diag(S), in
+*          the same storage format as A.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JC
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            JC = 1
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+   10          CONTINUE
+               JC = JC + J
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            JC = 1
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+   30          CONTINUE
+               JC = JC + N - J + 1
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of DLAQSP
+*
+      END
diff --git a/SRC/dlaqsy.f b/SRC/dlaqsy.f
new file mode 100644
index 00000000..23ffe755
--- /dev/null
+++ b/SRC/dlaqsy.f
@@ -0,0 +1,141 @@
+      SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            LDA, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQSY equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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 EQUED = 'Y', the equilibrated matrix:
+*          diag(S) * A * diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of DLAQSY
+*
+      END
diff --git a/SRC/dlaqtr.f b/SRC/dlaqtr.f
new file mode 100644
index 00000000..73639122
--- /dev/null
+++ b/SRC/dlaqtr.f
@@ -0,0 +1,665 @@
+      SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            LREAL, LTRAN
+      INTEGER            INFO, LDT, N
+      DOUBLE PRECISION   SCALE, W
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( * ), T( LDT, * ), WORK( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQTR solves the real quasi-triangular system
+*
+*               op(T)*p = scale*c,               if LREAL = .TRUE.
+*
+*  or the complex quasi-triangular systems
+*
+*             op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.
+*
+*  in real arithmetic, where T is upper quasi-triangular.
+*  If LREAL = .FALSE., then the first diagonal block of T must be
+*  1 by 1, B is the specially structured matrix
+*
+*                 B = [ b(1) b(2) ... b(n) ]
+*                     [       w            ]
+*                     [           w        ]
+*                     [              .     ]
+*                     [                 w  ]
+*
+*  op(A) = A or A', A' denotes the conjugate transpose of
+*  matrix A.
+*
+*  On input, X = [ c ].  On output, X = [ p ].
+*                [ d ]                  [ q ]
+*
+*  This subroutine is designed for the condition number estimation
+*  in routine DTRSNA.
+*
+*  Arguments
+*  =========
+*
+*  LTRAN   (input) LOGICAL
+*          On entry, LTRAN specifies the option of conjugate transpose:
+*             = .FALSE.,    op(T+i*B) = T+i*B,
+*             = .TRUE.,     op(T+i*B) = (T+i*B)'.
+*
+*  LREAL   (input) LOGICAL
+*          On entry, LREAL specifies the input matrix structure:
+*             = .FALSE.,    the input is complex
+*             = .TRUE.,     the input is real
+*
+*  N       (input) INTEGER
+*          On entry, N specifies the order of T+i*B. N >= 0.
+*
+*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
+*          On entry, T contains a matrix in Schur canonical form.
+*          If LREAL = .FALSE., then the first diagonal block of T mu
+*          be 1 by 1.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the matrix T. LDT >= max(1,N).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (N)
+*          On entry, B contains the elements to form the matrix
+*          B as described above.
+*          If LREAL = .TRUE., B is not referenced.
+*
+*  W       (input) DOUBLE PRECISION
+*          On entry, W is the diagonal element of the matrix B.
+*          If LREAL = .TRUE., W is not referenced.
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          On exit, SCALE is the scale factor.
+*
+*  X       (input/output) DOUBLE PRECISION array, dimension (2*N)
+*          On entry, X contains the right hand side of the system.
+*          On exit, X is overwritten by the solution.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO is set to
+*             0: successful exit.
+*               1: the some diagonal 1 by 1 block has been perturbed by
+*                  a small number SMIN to keep nonsingularity.
+*               2: the some diagonal 2 by 2 block has been perturbed by
+*                  a small number in DLALN2 to keep nonsingularity.
+*          NOTE: In the interests of speed, this routine does not
+*                check the inputs for errors.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            I, IERR, J, J1, J2, JNEXT, K, N1, N2
+      DOUBLE PRECISION   BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
+     $                   SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   D( 2, 2 ), V( 2, 2 )
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DDOT, DLAMCH, DLANGE
+      EXTERNAL           IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DLADIV, DLALN2, DSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Do not test the input parameters for errors
+*
+      NOTRAN = .NOT.LTRAN
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+      XNORM = DLANGE( 'M', N, N, T, LDT, D )
+      IF( .NOT.LREAL )
+     $   XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) )
+      SMIN = MAX( SMLNUM, EPS*XNORM )
+*
+*     Compute 1-norm of each column of strictly upper triangular
+*     part of T to control overflow in triangular solver.
+*
+      WORK( 1 ) = ZERO
+      DO 10 J = 2, N
+         WORK( J ) = DASUM( J-1, T( 1, J ), 1 )
+   10 CONTINUE
+*
+      IF( .NOT.LREAL ) THEN
+         DO 20 I = 2, N
+            WORK( I ) = WORK( I ) + ABS( B( I ) )
+   20    CONTINUE
+      END IF
+*
+      N2 = 2*N
+      N1 = N
+      IF( .NOT.LREAL )
+     $   N1 = N2
+      K = IDAMAX( N1, X, 1 )
+      XMAX = ABS( X( K ) )
+      SCALE = ONE
+*
+      IF( XMAX.GT.BIGNUM ) THEN
+         SCALE = BIGNUM / XMAX
+         CALL DSCAL( N1, SCALE, X, 1 )
+         XMAX = BIGNUM
+      END IF
+*
+      IF( LREAL ) THEN
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve T*p = scale*c
+*
+            JNEXT = N
+            DO 30 J = N, 1, -1
+               IF( J.GT.JNEXT )
+     $            GO TO 30
+               J1 = J
+               J2 = J
+               JNEXT = J - 1
+               IF( J.GT.1 ) THEN
+                  IF( T( J, J-1 ).NE.ZERO ) THEN
+                     J1 = J - 1
+                     JNEXT = J - 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 Meet 1 by 1 diagonal block
+*
+*                 Scale to avoid overflow when computing
+*                     x(j) = b(j)/T(j,j)
+*
+                  XJ = ABS( X( J1 ) )
+                  TJJ = ABS( T( J1, J1 ) )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMIN ) THEN
+                     TMP = SMIN
+                     TJJ = SMIN
+                     INFO = 1
+                  END IF
+*
+                  IF( XJ.EQ.ZERO )
+     $               GO TO 30
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J1 ) = X( J1 ) / TMP
+                  XJ = ABS( X( J1 ) )
+*
+*                 Scale x if necessary to avoid overflow when adding a
+*                 multiple of column j1 of T.
+*
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+                  IF( J1.GT.1 ) THEN
+                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     K = IDAMAX( J1-1, X, 1 )
+                     XMAX = ABS( X( K ) )
+                  END IF
+*
+               ELSE
+*
+*                 Meet 2 by 2 diagonal block
+*
+*                 Call 2 by 2 linear system solve, to take
+*                 care of possible overflow by scaling factor.
+*
+                  D( 1, 1 ) = X( J1 )
+                  D( 2, 1 ) = X( J2 )
+                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL DSCAL( N, SCALOC, X, 1 )
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+*
+*                 Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
+*                 to avoid overflow in updating right-hand side.
+*
+                  XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+     $                   ( BIGNUM-XMAX )*REC ) THEN
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+*
+*                 Update right-hand side
+*
+                  IF( J1.GT.1 ) THEN
+                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+                     K = IDAMAX( J1-1, X, 1 )
+                     XMAX = ABS( X( K ) )
+                  END IF
+*
+               END IF
+*
+   30       CONTINUE
+*
+         ELSE
+*
+*           Solve T'*p = scale*c
+*
+            JNEXT = 1
+            DO 40 J = 1, N
+               IF( J.LT.JNEXT )
+     $            GO TO 40
+               J1 = J
+               J2 = J
+               JNEXT = J + 1
+               IF( J.LT.N ) THEN
+                  IF( T( J+1, J ).NE.ZERO ) THEN
+                     J2 = J + 1
+                     JNEXT = J + 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 1 by 1 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side element by inner product.
+*
+                  XJ = ABS( X( J1 ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+*
+                  XJ = ABS( X( J1 ) )
+                  TJJ = ABS( T( J1, J1 ) )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMIN ) THEN
+                     TMP = SMIN
+                     TJJ = SMIN
+                     INFO = 1
+                  END IF
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J1 ) = X( J1 ) / TMP
+                  XMAX = MAX( XMAX, ABS( X( J1 ) ) )
+*
+               ELSE
+*
+*                 2 by 2 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side elements by inner product.
+*
+                  XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
+     $                   REC ) THEN
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
+     $                        1 )
+                  D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
+     $                        1 )
+*
+                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL DSCAL( N, SCALOC, X, 1 )
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+                  XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
+*
+               END IF
+   40       CONTINUE
+         END IF
+*
+      ELSE
+*
+         SMINW = MAX( EPS*ABS( W ), SMIN )
+         IF( NOTRAN ) THEN
+*
+*           Solve (T + iB)*(p+iq) = c+id
+*
+            JNEXT = N
+            DO 70 J = N, 1, -1
+               IF( J.GT.JNEXT )
+     $            GO TO 70
+               J1 = J
+               J2 = J
+               JNEXT = J - 1
+               IF( J.GT.1 ) THEN
+                  IF( T( J, J-1 ).NE.ZERO ) THEN
+                     J1 = J - 1
+                     JNEXT = J - 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 1 by 1 diagonal block
+*
+*                 Scale if necessary to avoid overflow in division
+*
+                  Z = W
+                  IF( J1.EQ.1 )
+     $               Z = B( 1 )
+                  XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+                  TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMINW ) THEN
+                     TMP = SMINW
+                     TJJ = SMINW
+                     INFO = 1
+                  END IF
+*
+                  IF( XJ.EQ.ZERO )
+     $               GO TO 70
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL DSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
+                  X( J1 ) = SR
+                  X( N+J1 ) = SI
+                  XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+*
+*                 Scale x if necessary to avoid overflow when adding a
+*                 multiple of column j1 of T.
+*
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+                        CALL DSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+*
+                  IF( J1.GT.1 ) THEN
+                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+     $                           X( N+1 ), 1 )
+*
+                     X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
+                     X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
+*
+                     XMAX = ZERO
+                     DO 50 K = 1, J1 - 1
+                        XMAX = MAX( XMAX, ABS( X( K ) )+
+     $                         ABS( X( K+N ) ) )
+   50                CONTINUE
+                  END IF
+*
+               ELSE
+*
+*                 Meet 2 by 2 diagonal block
+*
+                  D( 1, 1 ) = X( J1 )
+                  D( 2, 1 ) = X( J2 )
+                  D( 1, 2 ) = X( N+J1 )
+                  D( 2, 2 ) = X( N+J2 )
+                  CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL DSCAL( 2*N, SCALOC, X, 1 )
+                     SCALE = SCALOC*SCALE
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+                  X( N+J1 ) = V( 1, 2 )
+                  X( N+J2 ) = V( 2, 2 )
+*
+*                 Scale X(J1), .... to avoid overflow in
+*                 updating right hand side.
+*
+                  XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
+     $                 ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+     $                   ( BIGNUM-XMAX )*REC ) THEN
+                        CALL DSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+*
+*                 Update the right-hand side.
+*
+                  IF( J1.GT.1 ) THEN
+                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+*
+                     CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+     $                           X( N+1 ), 1 )
+                     CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
+     $                           X( N+1 ), 1 )
+*
+                     X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
+     $                        B( J2 )*X( N+J2 )
+                     X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
+     $                          B( J2 )*X( J2 )
+*
+                     XMAX = ZERO
+                     DO 60 K = 1, J1 - 1
+                        XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
+     $                         XMAX )
+   60                CONTINUE
+                  END IF
+*
+               END IF
+   70       CONTINUE
+*
+         ELSE
+*
+*           Solve (T + iB)'*(p+iq) = c+id
+*
+            JNEXT = 1
+            DO 80 J = 1, N
+               IF( J.LT.JNEXT )
+     $            GO TO 80
+               J1 = J
+               J2 = J
+               JNEXT = J + 1
+               IF( J.LT.N ) THEN
+                  IF( T( J+1, J ).NE.ZERO ) THEN
+                     J2 = J + 1
+                     JNEXT = J + 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 1 by 1 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side element by inner product.
+*
+                  XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+                        CALL DSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+                  X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
+     $                        X( N+1 ), 1 )
+                  IF( J1.GT.1 ) THEN
+                     X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
+                     X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
+                  END IF
+                  XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+*
+                  Z = W
+                  IF( J1.EQ.1 )
+     $               Z = B( 1 )
+*
+*                 Scale if necessary to avoid overflow in
+*                 complex division
+*
+                  TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMINW ) THEN
+                     TMP = SMINW
+                     TJJ = SMINW
+                     INFO = 1
+                  END IF
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL DSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
+                  X( J1 ) = SR
+                  X( J1+N ) = SI
+                  XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
+*
+               ELSE
+*
+*                 2 by 2 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side element by inner product.
+*
+                  XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+     $                 ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+     $                   ( BIGNUM-XJ ) / XMAX ) THEN
+                        CALL DSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
+     $                        1 )
+                  D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
+     $                        1 )
+                  D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
+     $                        X( N+1 ), 1 )
+                  D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1,
+     $                        X( N+1 ), 1 )
+                  D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
+                  D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
+                  D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
+                  D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
+*
+                  CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL DSCAL( N2, SCALOC, X, 1 )
+                     SCALE = SCALOC*SCALE
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+                  X( N+J1 ) = V( 1, 2 )
+                  X( N+J2 ) = V( 2, 2 )
+                  XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+     $                   ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
+*
+               END IF
+*
+   80       CONTINUE
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLAQTR
+*
+      END
diff --git a/SRC/dlar1v.f b/SRC/dlar1v.f
new file mode 100644
index 00000000..5f04dcc4
--- /dev/null
+++ b/SRC/dlar1v.f
@@ -0,0 +1,369 @@
+      SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
+     $           PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+     $           R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTNC
+      INTEGER   B1, BN, N, NEGCNT, R
+      DOUBLE PRECISION   GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+     $                   RQCORR, ZTZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * )
+      DOUBLE PRECISION   D( * ), L( * ), LD( * ), LLD( * ),
+     $                  WORK( * )
+      DOUBLE PRECISION Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAR1V computes the (scaled) r-th column of the inverse of
+*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+*  L D L^T - sigma I. When sigma is close to an eigenvalue, the
+*  computed vector is an accurate eigenvector. Usually, r corresponds
+*  to the index where the eigenvector is largest in magnitude.
+*  The following steps accomplish this computation :
+*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
+*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+*  (c) Computation of the diagonal elements of the inverse of
+*      L D L^T - sigma I by combining the above transforms, and choosing
+*      r as the index where the diagonal of the inverse is (one of the)
+*      largest in magnitude.
+*  (d) Computation of the (scaled) r-th column of the inverse using the
+*      twisted factorization obtained by combining the top part of the
+*      the stationary and the bottom part of the progressive transform.
+*
+*  Arguments
+*  =========
+*
+*  N        (input) INTEGER
+*           The order of the matrix L D L^T.
+*
+*  B1       (input) INTEGER
+*           First index of the submatrix of L D L^T.
+*
+*  BN       (input) INTEGER
+*           Last index of the submatrix of L D L^T.
+*
+*  LAMBDA    (input) DOUBLE PRECISION
+*           The shift. In order to compute an accurate eigenvector,
+*           LAMBDA should be a good approximation to an eigenvalue
+*           of L D L^T.
+*
+*  L        (input) DOUBLE PRECISION array, dimension (N-1)
+*           The (n-1) subdiagonal elements of the unit bidiagonal matrix
+*           L, in elements 1 to N-1.
+*
+*  D        (input) DOUBLE PRECISION array, dimension (N)
+*           The n diagonal elements of the diagonal matrix D.
+*
+*  LD       (input) DOUBLE PRECISION array, dimension (N-1)
+*           The n-1 elements L(i)*D(i).
+*
+*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)
+*           The n-1 elements L(i)*L(i)*D(i).
+*
+*  PIVMIN   (input) DOUBLE PRECISION
+*           The minimum pivot in the Sturm sequence.
+*
+*  GAPTOL   (input) DOUBLE PRECISION
+*           Tolerance that indicates when eigenvector entries are negligible
+*           w.r.t. their contribution to the residual.
+*
+*  Z        (input/output) DOUBLE PRECISION array, dimension (N)
+*           On input, all entries of Z must be set to 0.
+*           On output, Z contains the (scaled) r-th column of the
+*           inverse. The scaling is such that Z(R) equals 1.
+*
+*  WANTNC   (input) LOGICAL
+*           Specifies whether NEGCNT has to be computed.
+*
+*  NEGCNT   (output) INTEGER
+*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+*  ZTZ      (output) DOUBLE PRECISION
+*           The square of the 2-norm of Z.
+*
+*  MINGMA   (output) DOUBLE PRECISION
+*           The reciprocal of the largest (in magnitude) diagonal
+*           element of the inverse of L D L^T - sigma I.
+*
+*  R        (input/output) INTEGER
+*           The twist index for the twisted factorization used to
+*           compute Z.
+*           On input, 0 <= R <= N. If R is input as 0, R is set to
+*           the index where (L D L^T - sigma I)^{-1} is largest
+*           in magnitude. If 1 <= R <= N, R is unchanged.
+*           On output, R contains the twist index used to compute Z.
+*           Ideally, R designates the position of the maximum entry in the
+*           eigenvector.
+*
+*  ISUPPZ   (output) INTEGER array, dimension (2)
+*           The support of the vector in Z, i.e., the vector Z is
+*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+*  NRMINV   (output) DOUBLE PRECISION
+*           NRMINV = 1/SQRT( ZTZ )
+*
+*  RESID    (output) DOUBLE PRECISION
+*           The residual of the FP vector.
+*           RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+*  RQCORR   (output) DOUBLE PRECISION
+*           The Rayleigh Quotient correction to LAMBDA.
+*           RQCORR = MINGMA*TMP
+*
+*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SAWNAN1, SAWNAN2
+      INTEGER            I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
+     $                   R2
+      DOUBLE PRECISION   DMINUS, DPLUS, EPS, S, TMP
+*     ..
+*     .. External Functions ..
+      LOGICAL DISNAN
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DISNAN, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = DLAMCH( 'Precision' )
+
+
+      IF( R.EQ.0 ) THEN
+         R1 = B1
+         R2 = BN
+      ELSE
+         R1 = R
+         R2 = R
+      END IF
+
+*     Storage for LPLUS
+      INDLPL = 0
+*     Storage for UMINUS
+      INDUMN = N
+      INDS = 2*N + 1
+      INDP = 3*N + 1
+
+      IF( B1.EQ.1 ) THEN
+         WORK( INDS ) = ZERO
+      ELSE
+         WORK( INDS+B1-1 ) = LLD( B1-1 )
+      END IF
+
+*
+*     Compute the stationary transform (using the differential form)
+*     until the index R2.
+*
+      SAWNAN1 = .FALSE.
+      NEG1 = 0
+      S = WORK( INDS+B1-1 ) - LAMBDA
+      DO 50 I = B1, R1 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 50   CONTINUE
+      SAWNAN1 = DISNAN( S )
+      IF( SAWNAN1 ) GOTO 60
+      DO 51 I = R1, R2 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 51   CONTINUE
+      SAWNAN1 = DISNAN( S )
+*
+ 60   CONTINUE
+      IF( SAWNAN1 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG1 = 0
+         S = WORK( INDS+B1-1 ) - LAMBDA
+         DO 70 I = B1, R1 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 70      CONTINUE
+         DO 71 I = R1, R2 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 71      CONTINUE
+      END IF
+*
+*     Compute the progressive transform (using the differential form)
+*     until the index R1
+*
+      SAWNAN2 = .FALSE.
+      NEG2 = 0
+      WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
+      DO 80 I = BN - 1, R1, -1
+         DMINUS = LLD( I ) + WORK( INDP+I )
+         TMP = D( I ) / DMINUS
+         IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+         WORK( INDUMN+I ) = L( I )*TMP
+         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ 80   CONTINUE
+      TMP = WORK( INDP+R1-1 )
+      SAWNAN2 = DISNAN( TMP )
+
+      IF( SAWNAN2 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG2 = 0
+         DO 100 I = BN-1, R1, -1
+            DMINUS = LLD( I ) + WORK( INDP+I )
+            IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
+            TMP = D( I ) / DMINUS
+            IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+            WORK( INDUMN+I ) = L( I )*TMP
+            WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+            IF( TMP.EQ.ZERO )
+     $          WORK( INDP+I-1 ) = D( I ) - LAMBDA
+ 100     CONTINUE
+      END IF
+*
+*     Find the index (from R1 to R2) of the largest (in magnitude)
+*     diagonal element of the inverse
+*
+      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
+      IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
+      IF( WANTNC ) THEN
+         NEGCNT = NEG1 + NEG2
+      ELSE
+         NEGCNT = -1
+      ENDIF
+      IF( ABS(MINGMA).EQ.ZERO )
+     $   MINGMA = EPS*WORK( INDS+R1-1 )
+      R = R1
+      DO 110 I = R1, R2 - 1
+         TMP = WORK( INDS+I ) + WORK( INDP+I )
+         IF( TMP.EQ.ZERO )
+     $      TMP = EPS*WORK( INDS+I )
+         IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
+            MINGMA = TMP
+            R = I + 1
+         END IF
+ 110  CONTINUE
+*
+*     Compute the FP vector: solve N^T v = e_r
+*
+      ISUPPZ( 1 ) = B1
+      ISUPPZ( 2 ) = BN
+      Z( R ) = ONE
+      ZTZ = ONE
+*
+*     Compute the FP vector upwards from R
+*
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 210 I = R-1, B1, -1
+            Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GOTO 220
+            ENDIF
+            ZTZ = ZTZ + Z( I )*Z( I )
+ 210     CONTINUE
+ 220     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 230 I = R - 1, B1, -1
+            IF( Z( I+1 ).EQ.ZERO ) THEN
+               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
+            ELSE
+               Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GO TO 240
+            END IF
+            ZTZ = ZTZ + Z( I )*Z( I )
+ 230     CONTINUE
+ 240     CONTINUE
+      ENDIF
+
+*     Compute the FP vector downwards from R in blocks of size BLKSIZ
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 250 I = R, BN-1
+            Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $         THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 260
+            END IF
+            ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 250     CONTINUE
+ 260     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 270 I = R, BN - 1
+            IF( Z( I ).EQ.ZERO ) THEN
+               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
+            ELSE
+               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 280
+            END IF
+            ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 270     CONTINUE
+ 280     CONTINUE
+      END IF
+*
+*     Compute quantities for convergence test
+*
+      TMP = ONE / ZTZ
+      NRMINV = SQRT( TMP )
+      RESID = ABS( MINGMA )*NRMINV
+      RQCORR = MINGMA*TMP
+*
+*
+      RETURN
+*
+*     End of DLAR1V
+*
+      END
diff --git a/SRC/dlar2v.f b/SRC/dlar2v.f
new file mode 100644
index 00000000..55bfab90
--- /dev/null
+++ b/SRC/dlar2v.f
@@ -0,0 +1,86 @@
+      SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), S( * ), X( * ), Y( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAR2V applies a vector of real plane rotations from both sides to
+*  a sequence of 2-by-2 real symmetric matrices, defined by the elements
+*  of the vectors x, y and z. For i = 1,2,...,n
+*
+*     ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )
+*     ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector x.
+*
+*  Y       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector y.
+*
+*  Z       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector z.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X, Y and Z. INCX > 0.
+*
+*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX
+      DOUBLE PRECISION   CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = X( IX )
+         YI = Y( IX )
+         ZI = Z( IX )
+         CI = C( IC )
+         SI = S( IC )
+         T1 = SI*ZI
+         T2 = CI*ZI
+         T3 = T2 - SI*XI
+         T4 = T2 + SI*YI
+         T5 = CI*XI + T1
+         T6 = CI*YI - T1
+         X( IX ) = CI*T5 + SI*T4
+         Y( IX ) = CI*T6 - SI*T3
+         Z( IX ) = CI*T4 - SI*T5
+         IX = IX + INCX
+         IC = IC + INCC
+   10 CONTINUE
+*
+*     End of DLAR2V
+*
+      RETURN
+      END
diff --git a/SRC/dlarf.f b/SRC/dlarf.f
new file mode 100644
index 00000000..70752002
--- /dev/null
+++ b/SRC/dlarf.f
@@ -0,0 +1,152 @@
+      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            APPLYLEFT
+      INTEGER            I, LASTV, LASTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILADLR, ILADLC
+      EXTERNAL           LSAME, ILADLR, ILADLC
+*     ..
+*     .. Executable Statements ..
+*
+      APPLYLEFT = LSAME( SIDE, 'L' )
+      LASTV = 0
+      LASTC = 0
+      IF( TAU.NE.ZERO ) THEN
+!     Set up variables for scanning V.  LASTV begins pointing to the end
+!     of V.
+         IF( APPLYLEFT ) THEN
+            LASTV = M
+         ELSE
+            LASTV = N
+         END IF
+         IF( INCV.GT.0 ) THEN
+            I = 1 + (LASTV-1) * INCV
+         ELSE
+            I = 1
+         END IF
+!     Look for the last non-zero row in V.
+         DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
+            LASTV = LASTV - 1
+            I = I - INCV
+         END DO
+         IF( APPLYLEFT ) THEN
+!     Scan for the last non-zero column in C(1:lastv,:).
+            LASTC = ILADLC(LASTV, N, C, LDC)
+         ELSE
+!     Scan for the last non-zero row in C(:,1:lastv).
+            LASTC = ILADLR(M, LASTV, C, LDC)
+         END IF
+      END IF
+!     Note that lastc.eq.0 renders the BLAS operations null; no special
+!     case is needed at this level.
+      IF( APPLYLEFT ) THEN
+*
+*        Form  H * C
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
+*
+            CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
+     $           ZERO, WORK, 1 )
+*
+*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
+*
+            CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+            CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
+     $           V, INCV, ZERO, WORK, 1 )
+*
+*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
+*
+            CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLARF
+*
+      END
diff --git a/SRC/dlarfb.f b/SRC/dlarfb.f
new file mode 100644
index 00000000..d7fb3c51
--- /dev/null
+++ b/SRC/dlarfb.f
@@ -0,0 +1,640 @@
+      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+      IMPLICIT NONE
+*
+*  -- 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, LASTV, LASTC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILADLR, ILADLC
+      EXTERNAL           LSAME, ILADLR, ILADLC
+*     ..
+*     .. 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 )
+*
+               LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
+               LASTC = ILADLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL DGEMM( 'Transpose', 'No transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                 LASTV-K, LASTC, 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',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
+               LASTC = ILADLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL DGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, LASTV-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',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILADLR( M, K, V, LDV ) )
+               LASTC = ILADLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL DGEMM( 'Transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-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 )
+*
+               LASTV = MAX( K, ILADLR( N, K, V, LDV ) )
+               LASTC = ILADLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL DGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-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 )
+*
+               LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
+               LASTC = ILADLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose',
+     $                 LASTV-K, LASTC, 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',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
+               LASTC = ILADLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL DGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-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',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILADLC( K, M, V, LDV ) )
+               LASTC = ILADLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL DCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose',
+     $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-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 )
+*
+               LASTV = MAX( K, ILADLC( K, N, V, LDV ) )
+               LASTC = ILADLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL DCOPY( LASTC, C( 1, LASTV-K+J ), 1,
+     $                 WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL DGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLARFB
+*
+      END
diff --git a/SRC/dlarfg.f b/SRC/dlarfg.f
new file mode 100644
index 00000000..a569344b
--- /dev/null
+++ b/SRC/dlarfg.f
@@ -0,0 +1,133 @@
+      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' )
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            RSAFMN = ONE / SAFMIN
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL DSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHA = ALPHA*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DNRM2( N-1, X, INCX )
+            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+         END IF
+         TAU = ( BETA-ALPHA ) / BETA
+         CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+*
+*        If ALPHA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of DLARFG
+*
+      END
diff --git a/SRC/dlarfp.f b/SRC/dlarfp.f
new file mode 100644
index 00000000..f224f6fb
--- /dev/null
+++ b/SRC/dlarfp.f
@@ -0,0 +1,155 @@
+      SUBROUTINE DLARFP( 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
+*  =======
+*
+*  DLARFP 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, beta is non-negative, and x is
+*  an (n-1)-element real vector.  H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( 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   TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0D+0, 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.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = DNRM2( N-1, X, INCX )
+*
+      IF( XNORM.EQ.ZERO ) THEN
+*
+*        H  =  [+/-1, 0; I], sign chosen so ALPHA >= 0
+*
+         IF( ALPHA.GE.ZERO ) THEN
+!           When TAU.eq.ZERO, the vector is special-cased to be
+!           all zeros in the application routines.  We do not need
+!           to clear it.
+            TAU = ZERO
+         ELSE
+!           However, the application routines rely on explicit
+!           zero checks when TAU.ne.ZERO, and we must clear X.
+            TAU = TWO
+            DO J = 1, N-1
+               X( 1 + (J-1)*INCX ) = 0
+            END DO
+            ALPHA = -ALPHA
+         END IF
+      ELSE
+*
+*        general case
+*
+         BETA = SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            RSAFMN = ONE / SAFMIN
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL DSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHA = ALPHA*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DNRM2( N-1, X, INCX )
+            BETA = SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+         END IF
+         ALPHA = ALPHA + BETA
+         IF( BETA.LT.ZERO ) THEN
+            BETA = -BETA
+            TAU = -ALPHA / BETA
+         ELSE
+            ALPHA = XNORM * (XNORM/ALPHA)
+            TAU = ALPHA / BETA
+            ALPHA = -ALPHA
+         END IF
+         CALL DSCAL( N-1, ONE / ALPHA, X, INCX )
+*
+*        If BETA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of DLARFP
+*
+      END
+
diff --git a/SRC/dlarft.f b/SRC/dlarft.f
new file mode 100644
index 00000000..9d2870a9
--- /dev/null
+++ b/SRC/dlarft.f
@@ -0,0 +1,251 @@
+      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+      IMPLICIT NONE
+*
+*  -- 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, PREVLASTV, LASTV
+      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
+         PREVLASTV = N
+         DO 20 I = 1, K
+            PREVLASTV = MAX( I, PREVLASTV )
+            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
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( LASTV, I ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i)
+*
+                  CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ),
+     $                        V( I, 1 ), LDV, V( I, I ), 1, ZERO,
+     $                        T( 1, I ), 1 )
+               ELSE
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( I, LASTV ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)'
+*
+                  CALL DGEMV( 'No transpose', I-1, J-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 )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MAX( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   20    CONTINUE
+      ELSE
+         PREVLASTV = 1
+         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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( LASTV, I ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i)
+*
+                     CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ),
+     $                           V( J, I+1 ), LDV, V( J, 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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( I, LASTV ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)'
+*
+                     CALL DGEMV( 'No transpose', K-I, N-K+I-J+1,
+     $                    -TAU( I ), V( I+1, J ), LDV, V( I, J ), 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 )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MIN( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DLARFT
+*
+      END
diff --git a/SRC/dlarfx.f b/SRC/dlarfx.f
new file mode 100644
index 00000000..8412acbf
--- /dev/null
+++ b/SRC/dlarfx.f
@@ -0,0 +1,625 @@
+      SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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           DLARF
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+         CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 20 J = 1, N
+            C( 1, J ) = T1*C( 1, J )
+   20    CONTINUE
+         GO TO 410
+   30    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 40 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+   40    CONTINUE
+         GO TO 410
+   50    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 60 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+   60    CONTINUE
+         GO TO 410
+   70    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 80 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+   80    CONTINUE
+         GO TO 410
+   90    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 100 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+  100    CONTINUE
+         GO TO 410
+  110    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 120 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+  120    CONTINUE
+         GO TO 410
+  130    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 140 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+  140    CONTINUE
+         GO TO 410
+  150    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 160 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+  160    CONTINUE
+         GO TO 410
+  170    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 180 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+  180    CONTINUE
+         GO TO 410
+  190    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+         CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 220 J = 1, M
+            C( J, 1 ) = T1*C( J, 1 )
+  220    CONTINUE
+         GO TO 410
+  230    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 240 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+  240    CONTINUE
+         GO TO 410
+  250    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 260 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+  260    CONTINUE
+         GO TO 410
+  270    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 280 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+  280    CONTINUE
+         GO TO 410
+  290    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 300 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+  300    CONTINUE
+         GO TO 410
+  310    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 320 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+  320    CONTINUE
+         GO TO 410
+  330    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 340 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+  340    CONTINUE
+         GO TO 410
+  350    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 360 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+  360    CONTINUE
+         GO TO 410
+  370    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 380 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+  380    CONTINUE
+         GO TO 410
+  390    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 400 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+     $            V10*C( J, 10 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+            C( J, 10 ) = C( J, 10 ) - SUM*T10
+  400    CONTINUE
+         GO TO 410
+      END IF
+  410 CONTINUE
+      RETURN
+*
+*     End of DLARFX
+*
+      END
diff --git a/SRC/dlargv.f b/SRC/dlargv.f
new file mode 100644
index 00000000..ca0e9405
--- /dev/null
+++ b/SRC/dlargv.f
@@ -0,0 +1,99 @@
+      SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARGV generates a vector of real plane rotations, determined by
+*  elements of the real vectors x and y. For i = 1,2,...,n
+*
+*     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )
+*     ( -s(i)  c(i) ) ( y(i) ) = (   0  )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be generated.
+*
+*  X       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCX)
+*          On entry, the vector x.
+*          On exit, x(i) is overwritten by a(i), for i = 1,...,n.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCY)
+*          On entry, the vector y.
+*          On exit, the sines of the plane rotations.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX, IY
+      DOUBLE PRECISION   F, G, T, TT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 10 I = 1, N
+         F = X( IX )
+         G = Y( IY )
+         IF( G.EQ.ZERO ) THEN
+            C( IC ) = ONE
+         ELSE IF( F.EQ.ZERO ) THEN
+            C( IC ) = ZERO
+            Y( IY ) = ONE
+            X( IX ) = G
+         ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
+            T = G / F
+            TT = SQRT( ONE+T*T )
+            C( IC ) = ONE / TT
+            Y( IY ) = T*C( IC )
+            X( IX ) = F*TT
+         ELSE
+            T = F / G
+            TT = SQRT( ONE+T*T )
+            Y( IY ) = ONE / TT
+            C( IC ) = T*Y( IY )
+            X( IX ) = G*TT
+         END IF
+         IC = IC + INCC
+         IY = IY + INCY
+         IX = IX + INCX
+   10 CONTINUE
+      RETURN
+*
+*     End of DLARGV
+*
+      END
diff --git a/SRC/dlarnv.f b/SRC/dlarnv.f
new file mode 100644
index 00000000..bc3273c0
--- /dev/null
+++ b/SRC/dlarnv.f
@@ -0,0 +1,115 @@
+      SUBROUTINE DLARNV( IDIST, ISEED, N, X )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IDIST, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISEED( 4 )
+      DOUBLE PRECISION   X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARNV returns a vector of n random real numbers from a uniform or
+*  normal distribution.
+*
+*  Arguments
+*  =========
+*
+*  IDIST   (input) INTEGER
+*          Specifies the distribution of the random numbers:
+*          = 1:  uniform (0,1)
+*          = 2:  uniform (-1,1)
+*          = 3:  normal (0,1)
+*
+*  ISEED   (input/output) INTEGER array, dimension (4)
+*          On entry, the seed of the random number generator; the array
+*          elements must be between 0 and 4095, and ISEED(4) must be
+*          odd.
+*          On exit, the seed is updated.
+*
+*  N       (input) INTEGER
+*          The number of random numbers to be generated.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (N)
+*          The generated random numbers.
+*
+*  Further Details
+*  ===============
+*
+*  This routine calls the auxiliary routine DLARUV to generate random
+*  real numbers from a uniform (0,1) distribution, in batches of up to
+*  128 using vectorisable code. The Box-Muller method is used to
+*  transform numbers from a uniform to a normal distribution.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, TWO
+      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0 )
+      INTEGER            LV
+      PARAMETER          ( LV = 128 )
+      DOUBLE PRECISION   TWOPI
+      PARAMETER          ( TWOPI = 6.2831853071795864769252867663D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IL, IL2, IV
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   U( LV )
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          COS, LOG, MIN, SQRT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARUV
+*     ..
+*     .. Executable Statements ..
+*
+      DO 40 IV = 1, N, LV / 2
+         IL = MIN( LV / 2, N-IV+1 )
+         IF( IDIST.EQ.3 ) THEN
+            IL2 = 2*IL
+         ELSE
+            IL2 = IL
+         END IF
+*
+*        Call DLARUV to generate IL2 numbers from a uniform (0,1)
+*        distribution (IL2 <= LV)
+*
+         CALL DLARUV( ISEED, IL2, U )
+*
+         IF( IDIST.EQ.1 ) THEN
+*
+*           Copy generated numbers
+*
+            DO 10 I = 1, IL
+               X( IV+I-1 ) = U( I )
+   10       CONTINUE
+         ELSE IF( IDIST.EQ.2 ) THEN
+*
+*           Convert generated numbers to uniform (-1,1) distribution
+*
+            DO 20 I = 1, IL
+               X( IV+I-1 ) = TWO*U( I ) - ONE
+   20       CONTINUE
+         ELSE IF( IDIST.EQ.3 ) THEN
+*
+*           Convert generated numbers to normal (0,1) distribution
+*
+            DO 30 I = 1, IL
+               X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
+     $                       COS( TWOPI*U( 2*I ) )
+   30       CONTINUE
+         END IF
+   40 CONTINUE
+      RETURN
+*
+*     End of DLARNV
+*
+      END
diff --git a/SRC/dlarra.f b/SRC/dlarra.f
new file mode 100644
index 00000000..44f2a455
--- /dev/null
+++ b/SRC/dlarra.f
@@ -0,0 +1,130 @@
+      SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM,
+     $                    NSPLIT, ISPLIT, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N, NSPLIT
+      DOUBLE PRECISION    SPLTOL, TNRM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISPLIT( * )
+      DOUBLE PRECISION   D( * ), E( * ), E2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Compute the splitting points with threshold SPLTOL.
+*  DLARRA sets any "small" off-diagonal elements to zero.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal
+*          matrix T.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the first (N-1) entries contain the subdiagonal
+*          elements of the tridiagonal matrix T; E(N) need not be set.
+*          On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
+*          are set to zero, the other entries of E are untouched.
+*
+*  E2      (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the first (N-1) entries contain the SQUARES of the
+*          subdiagonal elements of the tridiagonal matrix T;
+*          E2(N) need not be set.
+*          On exit, the entries E2( ISPLIT( I ) ),
+*          1 <= I <= NSPLIT, have been set to zero
+*
+*  SPLTOL (input) DOUBLE PRECISION
+*          The threshold for splitting. Two criteria can be used:
+*          SPLTOL<0 : criterion based on absolute off-diagonal value
+*          SPLTOL>0 : criterion that preserves relative accuracy
+*
+*  TNRM (input) DOUBLE PRECISION
+*          The norm of the matrix.
+*
+*  NSPLIT  (output) INTEGER
+*          The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+*  ISPLIT  (output) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   EABS, TMP1
+
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+
+*     Compute splitting points
+      NSPLIT = 1
+      IF(SPLTOL.LT.ZERO) THEN
+*        Criterion based on absolute off-diagonal value
+         TMP1 = ABS(SPLTOL)* TNRM
+         DO 9 I = 1, N-1
+            EABS = ABS( E(I) )
+            IF( EABS .LE. TMP1) THEN
+               E(I) = ZERO
+               E2(I) = ZERO
+               ISPLIT( NSPLIT ) = I
+               NSPLIT = NSPLIT + 1
+            END IF
+ 9       CONTINUE
+      ELSE
+*        Criterion that guarantees relative accuracy
+         DO 10 I = 1, N-1
+            EABS = ABS( E(I) )
+            IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
+     $      THEN
+               E(I) = ZERO
+               E2(I) = ZERO
+               ISPLIT( NSPLIT ) = I
+               NSPLIT = NSPLIT + 1
+            END IF
+ 10      CONTINUE
+      ENDIF
+      ISPLIT( NSPLIT ) = N
+
+      RETURN
+*
+*     End of DLARRA
+*
+      END
diff --git a/SRC/dlarrb.f b/SRC/dlarrb.f
new file mode 100644
index 00000000..ede18985
--- /dev/null
+++ b/SRC/dlarrb.f
@@ -0,0 +1,298 @@
+      SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
+     $                   RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
+     $                   PIVMIN, SPDIAM, TWIST, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IFIRST, ILAST, INFO, N, OFFSET, TWIST
+      DOUBLE PRECISION   PIVMIN, RTOL1, RTOL2, SPDIAM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), LLD( * ), W( * ),
+     $                   WERR( * ), WGAP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given the relatively robust representation(RRR) L D L^T, DLARRB
+*  does "limited" bisection to refine the eigenvalues of L D L^T,
+*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+*  guesses for these eigenvalues are input in W, the corresponding estimate
+*  of the error in these guesses and their gaps are input in WERR
+*  and WGAP, respectively. During bisection, intervals
+*  [left, right] are maintained by storing their mid-points and
+*  semi-widths in the arrays W and WERR respectively.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D.
+*
+*  LLD     (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (N-1) elements L(i)*L(i)*D(i).
+*
+*  IFIRST  (input) INTEGER
+*          The index of the first eigenvalue to be computed.
+*
+*  ILAST   (input) INTEGER
+*          The index of the last eigenvalue to be computed.
+*
+*  RTOL1   (input) DOUBLE PRECISION
+*  RTOL2   (input) DOUBLE PRECISION
+*          Tolerance for the convergence of the bisection intervals.
+*          An interval [LEFT,RIGHT] has converged if
+*          RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*          where GAP is the (estimated) distance to the nearest
+*          eigenvalue.
+*
+*  OFFSET  (input) INTEGER
+*          Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
+*          through ILAST-OFFSET elements of these arrays are to be used.
+*
+*  W       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+*          estimates of the eigenvalues of L D L^T indexed IFIRST throug
+*          ILAST.
+*          On output, these estimates are refined.
+*
+*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On input, the (estimated) gaps between consecutive
+*          eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
+*          eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
+*          then WGAP(IFIRST-OFFSET) must be set to ZERO.
+*          On output, these gaps are refined.
+*
+*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)
+*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+*          the errors in the estimates of the corresponding elements in W.
+*          On output, these errors are refined.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*N)
+*          Workspace.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence.
+*
+*  SPDIAM  (input) DOUBLE PRECISION
+*          The spectral diameter of the matrix.
+*
+*  TWIST   (input) INTEGER
+*          The twist index for the twisted factorization that is used
+*          for the negcount.
+*          TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
+*          TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
+*          TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
+*
+*  INFO    (output) INTEGER
+*          Error flag.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, TWO, HALF
+      PARAMETER        ( ZERO = 0.0D0, TWO = 2.0D0,
+     $                   HALF = 0.5D0 )
+      INTEGER   MAXITR
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
+     $                   OLNINT, PREV, R
+      DOUBLE PRECISION   BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
+     $                   RGAP, RIGHT, TMP, WIDTH
+*     ..
+*     .. External Functions ..
+      INTEGER            DLANEG
+      EXTERNAL           DLANEG
+*
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+      MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+      MNWDTH = TWO * PIVMIN
+*
+      R = TWIST
+      IF((R.LT.1).OR.(R.GT.N)) R = N
+*
+*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+*     for an unconverged interval is set to the index of the next unconverged
+*     interval, and is -1 or 0 for a converged interval. Thus a linked
+*     list of unconverged intervals is set up.
+*
+      I1 = IFIRST
+*     The number of unconverged intervals
+      NINT = 0
+*     The last unconverged interval found
+      PREV = 0
+
+      RGAP = WGAP( I1-OFFSET )
+      DO 75 I = I1, ILAST
+         K = 2*I
+         II = I - OFFSET
+         LEFT = W( II ) - WERR( II )
+         RIGHT = W( II ) + WERR( II )
+         LGAP = RGAP
+         RGAP = WGAP( II )
+         GAP = MIN( LGAP, RGAP )
+
+*        Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
+*
+*        Do while( NEGCNT(LEFT).GT.I-1 )
+*
+         BACK = WERR( II )
+ 20      CONTINUE
+         NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R )
+         IF( NEGCNT.GT.I-1 ) THEN
+            LEFT = LEFT - BACK
+            BACK = TWO*BACK
+            GO TO 20
+         END IF
+*
+*        Do while( NEGCNT(RIGHT).LT.I )
+*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
+*
+         BACK = WERR( II )
+ 50      CONTINUE
+
+         NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R )
+          IF( NEGCNT.LT.I ) THEN
+             RIGHT = RIGHT + BACK
+             BACK = TWO*BACK
+             GO TO 50
+          END IF
+         WIDTH = HALF*ABS( LEFT - RIGHT )
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+         CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+         IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
+*           This interval has already converged and does not need refinement.
+*           (Note that the gaps might change through refining the
+*            eigenvalues, however, they can only get bigger.)
+*           Remove it from the list.
+            IWORK( K-1 ) = -1
+*           Make sure that I1 always points to the first unconverged interval
+            IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
+            IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
+         ELSE
+*           unconverged interval found
+            PREV = I
+            NINT = NINT + 1
+            IWORK( K-1 ) = I + 1
+            IWORK( K ) = NEGCNT
+         END IF
+         WORK( K-1 ) = LEFT
+         WORK( K ) = RIGHT
+ 75   CONTINUE
+
+*
+*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+*     and while (ITER.LT.MAXITR)
+*
+      ITER = 0
+ 80   CONTINUE
+      PREV = I1 - 1
+      I = I1
+      OLNINT = NINT
+
+      DO 100 IP = 1, OLNINT
+         K = 2*I
+         II = I - OFFSET
+         RGAP = WGAP( II )
+         LGAP = RGAP
+         IF(II.GT.1) LGAP = WGAP( II-1 )
+         GAP = MIN( LGAP, RGAP )
+         NEXT = IWORK( K-1 )
+         LEFT = WORK( K-1 )
+         RIGHT = WORK( K )
+         MID = HALF*( LEFT + RIGHT )
+
+*        semiwidth of interval
+         WIDTH = RIGHT - MID
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+         CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+         IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
+     $       ( ITER.EQ.MAXITR ) )THEN
+*           reduce number of unconverged intervals
+            NINT = NINT - 1
+*           Mark interval as converged.
+            IWORK( K-1 ) = 0
+            IF( I1.EQ.I ) THEN
+               I1 = NEXT
+            ELSE
+*              Prev holds the last unconverged interval previously examined
+               IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+            END IF
+            I = NEXT
+            GO TO 100
+         END IF
+         PREV = I
+*
+*        Perform one bisection step
+*
+         NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R )
+         IF( NEGCNT.LE.I-1 ) THEN
+            WORK( K-1 ) = MID
+         ELSE
+            WORK( K ) = MID
+         END IF
+         I = NEXT
+ 100  CONTINUE
+      ITER = ITER + 1
+*     do another loop if there are still unconverged intervals
+*     However, in the last iteration, all intervals are accepted
+*     since this is the best we can do.
+      IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+*     At this point, all the intervals have converged
+      DO 110 I = IFIRST, ILAST
+         K = 2*I
+         II = I - OFFSET
+*        All intervals marked by '0' have been refined.
+         IF( IWORK( K-1 ).EQ.0 ) THEN
+            W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+            WERR( II ) = WORK( K ) - W( II )
+         END IF
+ 110  CONTINUE
+*
+      DO 111 I = IFIRST+1, ILAST
+         K = 2*I
+         II = I - OFFSET
+         WGAP( II-1 ) = MAX( ZERO,
+     $                     W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
+ 111  CONTINUE
+
+      RETURN
+*
+*     End of DLARRB
+*
+      END
diff --git a/SRC/dlarrc.f b/SRC/dlarrc.f
new file mode 100644
index 00000000..c75b7ef2
--- /dev/null
+++ b/SRC/dlarrc.f
@@ -0,0 +1,159 @@
+      SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
+     $                            EIGCNT, LCNT, RCNT, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBT
+      INTEGER            EIGCNT, INFO, LCNT, N, RCNT
+      DOUBLE PRECISION   PIVMIN, VL, VU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Find the number of eigenvalues of the symmetric tridiagonal matrix T
+*  that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
+*  if JOBT = 'L'.
+*
+*  Arguments
+*  =========
+*
+*  JOBT    (input) CHARACTER*1
+*          = 'T':  Compute Sturm count for matrix T.
+*          = 'L':  Compute Sturm count for matrix L D L^T.
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          The lower and upper bounds for the eigenvalues.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
+*          JOBT = 'L': The N diagonal elements of the diagonal matrix D.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N)
+*          JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
+*          JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence for T.
+*
+*  EIGCNT  (output) INTEGER
+*          The number of eigenvalues of the symmetric tridiagonal matrix T
+*          that are in the interval (VL,VU]
+*
+*  LCNT    (output) INTEGER
+*  RCNT    (output) INTEGER
+*          The left and right negcounts of the interval.
+*
+*  INFO    (output) INTEGER
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      LOGICAL            MATT
+      DOUBLE PRECISION   LPIVOT, RPIVOT, SL, SU, TMP, TMP2
+
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      LCNT = 0
+      RCNT = 0
+      EIGCNT = 0
+      MATT = LSAME( JOBT, 'T' )
+
+
+      IF (MATT) THEN
+*        Sturm sequence count on T
+         LPIVOT = D( 1 ) - VL
+         RPIVOT = D( 1 ) - VU
+         IF( LPIVOT.LE.ZERO ) THEN
+            LCNT = LCNT + 1
+         ENDIF
+         IF( RPIVOT.LE.ZERO ) THEN
+            RCNT = RCNT + 1
+         ENDIF
+         DO 10 I = 1, N-1
+            TMP = E(I)**2
+            LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
+            RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
+            IF( LPIVOT.LE.ZERO ) THEN
+               LCNT = LCNT + 1
+            ENDIF
+            IF( RPIVOT.LE.ZERO ) THEN
+               RCNT = RCNT + 1
+            ENDIF
+ 10      CONTINUE
+      ELSE
+*        Sturm sequence count on L D L^T
+         SL = -VL
+         SU = -VU
+         DO 20 I = 1, N - 1
+            LPIVOT = D( I ) + SL
+            RPIVOT = D( I ) + SU
+            IF( LPIVOT.LE.ZERO ) THEN
+               LCNT = LCNT + 1
+            ENDIF
+            IF( RPIVOT.LE.ZERO ) THEN
+               RCNT = RCNT + 1
+            ENDIF
+            TMP = E(I) * D(I) * E(I)
+*
+            TMP2 = TMP / LPIVOT
+            IF( TMP2.EQ.ZERO ) THEN
+               SL =  TMP - VL
+            ELSE
+               SL = SL*TMP2 - VL
+            END IF
+*
+            TMP2 = TMP / RPIVOT
+            IF( TMP2.EQ.ZERO ) THEN
+               SU =  TMP - VU
+            ELSE
+               SU = SU*TMP2 - VU
+            END IF
+ 20      CONTINUE
+         LPIVOT = D( N ) + SL
+         RPIVOT = D( N ) + SU
+         IF( LPIVOT.LE.ZERO ) THEN
+            LCNT = LCNT + 1
+         ENDIF
+         IF( RPIVOT.LE.ZERO ) THEN
+            RCNT = RCNT + 1
+         ENDIF
+      ENDIF
+      EIGCNT = RCNT - LCNT
+
+      RETURN
+*
+*     end of DLARRC
+*
+      END
diff --git a/SRC/dlarrd.f b/SRC/dlarrd.f
new file mode 100644
index 00000000..6cae51b7
--- /dev/null
+++ b/SRC/dlarrd.f
@@ -0,0 +1,713 @@
+      SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
+     $                    RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+     $                    M, W, WERR, WL, WU, IBLOCK, INDEXW,
+     $                    WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          ORDER, RANGE
+      INTEGER            IL, INFO, IU, M, N, NSPLIT
+      DOUBLE PRECISION    PIVMIN, RELTOL, VL, VU, WL, WU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), INDEXW( * ),
+     $                   ISPLIT( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), E2( * ),
+     $                   GERS( * ), W( * ), WERR( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARRD computes the eigenvalues of a symmetric tridiagonal
+*  matrix T to suitable accuracy. This is an auxiliary code to be
+*  called from DSTEMR.
+*  The user may ask for all eigenvalues, all eigenvalues
+*  in the half-open interval (VL, VU], or the IL-th through IU-th
+*  eigenvalues.
+*
+*  To avoid overflow, the matrix must be scaled so that its
+*  largest element is no greater than overflow**(1/2) *
+*  underflow**(1/4) in absolute value, and for greatest
+*  accuracy, it should not be much smaller than that.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966.
+*
+*  Arguments
+*  =========
+*
+*  RANGE   (input) CHARACTER
+*          = 'A': ("All")   all eigenvalues will be found.
+*          = 'V': ("Value") all eigenvalues in the half-open interval
+*                           (VL, VU] will be found.
+*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+*                           entire matrix) will be found.
+*
+*  ORDER   (input) CHARACTER
+*          = 'B': ("By Block") the eigenvalues will be grouped by
+*                              split-off block (see IBLOCK, ISPLIT) and
+*                              ordered from smallest to largest within
+*                              the block.
+*          = 'E': ("Entire matrix")
+*                              the eigenvalues for the entire matrix
+*                              will be ordered from smallest to
+*                              largest.
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal matrix T.  N >= 0.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues.  Eigenvalues less than or equal
+*          to VL, or greater than VU, will not be returned.  VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  GERS    (input) DOUBLE PRECISION array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)).
+*
+*  RELTOL  (input) DOUBLE PRECISION
+*          The minimum relative width of an interval.  When an interval
+*          is narrower than RELTOL times the larger (in
+*          magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  Note: this should
+*          always be at least radix*machine epsilon.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+*  E2      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence for T.
+*
+*  NSPLIT  (input) INTEGER
+*          The number of diagonal blocks in the matrix T.
+*          1 <= NSPLIT <= N.
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*          (Only the first NSPLIT elements will actually be used, but
+*          since the user cannot know a priori what value NSPLIT will
+*          have, N words must be reserved for ISPLIT.)
+*
+*  M       (output) INTEGER
+*          The actual number of eigenvalues found. 0 <= M <= N.
+*          (See also the description of INFO=2,3.)
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, the first M elements of W will contain the
+*          eigenvalue approximations. DLARRD computes an interval
+*          I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
+*          approximation is given as the interval midpoint
+*          W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
+*          WERR(j) = abs( a_j - b_j)/2
+*
+*  WERR    (output) DOUBLE PRECISION array, dimension (N)
+*          The error bound on the corresponding eigenvalue approximation
+*          in W.
+*
+*  WL      (output) DOUBLE PRECISION
+*  WU      (output) DOUBLE PRECISION
+*          The interval (WL, WU] contains all the wanted eigenvalues.
+*          If RANGE='V', then WL=VL and WU=VU.
+*          If RANGE='A', then WL and WU are the global Gerschgorin bounds
+*                        on the spectrum.
+*          If RANGE='I', then WL and WU are computed by DLAEBZ from the
+*                        index range specified.
+*
+*  IBLOCK  (output) INTEGER array, dimension (N)
+*          At each row/column j where E(j) is zero or small, the
+*          matrix T is considered to split into a block diagonal
+*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which
+*          block (from 1 to the number of blocks) the eigenvalue W(i)
+*          belongs.  (DLARRD may use the remaining N-M elements as
+*          workspace.)
+*
+*  INDEXW  (output) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
+*          i-th eigenvalue W(i) is the j-th eigenvalue in block k.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  some or all of the eigenvalues failed to converge or
+*                were not computed:
+*                =1 or 3: Bisection failed to converge for some
+*                        eigenvalues; these eigenvalues are flagged by a
+*                        negative block number.  The effect is that the
+*                        eigenvalues may not be as accurate as the
+*                        absolute and relative tolerances.  This is
+*                        generally caused by unexpectedly inaccurate
+*                        arithmetic.
+*                =2 or 3: RANGE='I' only: Not all of the eigenvalues
+*                        IL:IU were found.
+*                        Effect: M < IU+1-IL
+*                        Cause:  non-monotonic arithmetic, causing the
+*                                Sturm sequence to be non-monotonic.
+*                        Cure:   recalculate, using RANGE='A', and pick
+*                                out eigenvalues IL:IU.  In some cases,
+*                                increasing the PARAMETER "FUDGE" may
+*                                make things work.
+*                = 4:    RANGE='I', and the Gershgorin interval
+*                        initially used was too small.  No eigenvalues
+*                        were computed.
+*                        Probable cause: your machine has sloppy
+*                                        floating-point arithmetic.
+*                        Cure: Increase the PARAMETER "FUDGE",
+*                              recompile, and try again.
+*
+*  Internal Parameters
+*  ===================
+*
+*  FUDGE   DOUBLE PRECISION, default = 2
+*          A "fudge factor" to widen the Gershgorin intervals.  Ideally,
+*          a value of 1 should work, but on machines with sloppy
+*          arithmetic, this needs to be larger.  The default for
+*          publicly released versions should be large enough to handle
+*          the worst machine around.  Note that this has no effect
+*          on accuracy of the solution.
+*
+*  Based on contributions by
+*     W. Kahan, University of California, Berkeley, USA
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, HALF, FUDGE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0,
+     $                     TWO = 2.0D0, HALF = ONE/TWO,
+     $                     FUDGE = TWO )
+      INTEGER   ALLRNG, VALRNG, INDRNG
+      PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NCNVRG, TOOFEW
+      INTEGER            I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+     $                   IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
+     $                   ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
+     $                   NWL, NWU
+      DOUBLE PRECISION   ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
+     $                   TNORM, UFLOW, WKILL, WLU, WUL
+
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUMMA( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, ILAENV, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAEBZ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Decode RANGE
+*
+      IF( LSAME( RANGE, 'A' ) ) THEN
+         IRANGE = ALLRNG
+      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+         IRANGE = VALRNG
+      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+         IRANGE = INDRNG
+      ELSE
+         IRANGE = 0
+      END IF
+*
+*     Check for Errors
+*
+      IF( IRANGE.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( IRANGE.EQ.VALRNG ) THEN
+         IF( VL.GE.VU )
+     $      INFO = -5
+      ELSE IF( IRANGE.EQ.INDRNG .AND.
+     $        ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      ELSE IF( IRANGE.EQ.INDRNG .AND.
+     $        ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         RETURN
+      END IF
+
+*     Initialize error flags
+      INFO = 0
+      NCNVRG = .FALSE.
+      TOOFEW = .FALSE.
+
+*     Quick return if possible
+      M = 0
+      IF( N.EQ.0 ) RETURN
+
+*     Simplification:
+      IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
+
+*     Get machine constants
+      EPS = DLAMCH( 'P' )
+      UFLOW = DLAMCH( 'U' )
+
+
+*     Special Case when N=1
+*     Treat case of 1x1 matrix for quick return
+      IF( N.EQ.1 ) THEN
+         IF( (IRANGE.EQ.ALLRNG).OR.
+     $       ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+     $       ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+            M = 1
+            W(1) = D(1)
+*           The computation error of the eigenvalue is zero
+            WERR(1) = ZERO
+            IBLOCK( 1 ) = 1
+            INDEXW( 1 ) = 1
+         ENDIF
+         RETURN
+      END IF
+
+*     NB is the minimum vector length for vector bisection, or 0
+*     if only scalar is to be done.
+      NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
+      IF( NB.LE.1 ) NB = 0
+
+*     Find global spectral radius
+      GL = D(1)
+      GU = D(1)
+      DO 5 I = 1,N
+         GL =  MIN( GL, GERS( 2*I - 1))
+         GU = MAX( GU, GERS(2*I) )
+ 5    CONTINUE
+*     Compute global Gerschgorin bounds and spectral diameter
+      TNORM = MAX( ABS( GL ), ABS( GU ) )
+      GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+      GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+      SPDIAM = GU - GL
+*     Input arguments for DLAEBZ:
+*     The relative tolerance.  An interval (a,b] lies within
+*     "relative tolerance" if  b-a < RELTOL*max(|a|,|b|),
+      RTOLI = RELTOL
+*     Set the absolute tolerance for interval convergence to zero to force
+*     interval convergence based on relative size of the interval.
+*     This is dangerous because intervals might not converge when RELTOL is
+*     small. But at least a very small number should be selected so that for
+*     strongly graded matrices, the code can get relatively accurate
+*     eigenvalues.
+      ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
+
+      IF( IRANGE.EQ.INDRNG ) THEN
+
+*        RANGE='I': Compute an interval containing eigenvalues
+*        IL through IU. The initial interval [GL,GU] from the global
+*        Gerschgorin bounds GL and GU is refined by DLAEBZ.
+         ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+         WORK( N+1 ) = GL
+         WORK( N+2 ) = GL
+         WORK( N+3 ) = GU
+         WORK( N+4 ) = GU
+         WORK( N+5 ) = GL
+         WORK( N+6 ) = GU
+         IWORK( 1 ) = -1
+         IWORK( 2 ) = -1
+         IWORK( 3 ) = N + 1
+         IWORK( 4 ) = N + 1
+         IWORK( 5 ) = IL - 1
+         IWORK( 6 ) = IU
+*
+         CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN,
+     $         D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+     $                IWORK, W, IBLOCK, IINFO )
+         IF( IINFO .NE. 0 ) THEN
+            INFO = IINFO
+            RETURN
+         END IF
+*        On exit, output intervals may not be ordered by ascending negcount
+         IF( IWORK( 6 ).EQ.IU ) THEN
+            WL = WORK( N+1 )
+            WLU = WORK( N+3 )
+            NWL = IWORK( 1 )
+            WU = WORK( N+4 )
+            WUL = WORK( N+2 )
+            NWU = IWORK( 4 )
+         ELSE
+            WL = WORK( N+2 )
+            WLU = WORK( N+4 )
+            NWL = IWORK( 2 )
+            WU = WORK( N+3 )
+            WUL = WORK( N+1 )
+            NWU = IWORK( 3 )
+         END IF
+*        On exit, the interval [WL, WLU] contains a value with negcount NWL,
+*        and [WUL, WU] contains a value with negcount NWU.
+         IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+            INFO = 4
+            RETURN
+         END IF
+
+      ELSEIF( IRANGE.EQ.VALRNG ) THEN
+         WL = VL
+         WU = VU
+
+      ELSEIF( IRANGE.EQ.ALLRNG ) THEN
+         WL = GL
+         WU = GU
+      ENDIF
+
+
+
+*     Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
+*     NWL accumulates the number of eigenvalues .le. WL,
+*     NWU accumulates the number of eigenvalues .le. WU
+      M = 0
+      IEND = 0
+      INFO = 0
+      NWL = 0
+      NWU = 0
+*
+      DO 70 JBLK = 1, NSPLIT
+         IOFF = IEND
+         IBEGIN = IOFF + 1
+         IEND = ISPLIT( JBLK )
+         IN = IEND - IOFF
+*
+         IF( IN.EQ.1 ) THEN
+*           1x1 block
+            IF( WL.GE.D( IBEGIN )-PIVMIN )
+     $         NWL = NWL + 1
+            IF( WU.GE.D( IBEGIN )-PIVMIN )
+     $         NWU = NWU + 1
+            IF( IRANGE.EQ.ALLRNG .OR.
+     $           ( WL.LT.D( IBEGIN )-PIVMIN
+     $             .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
+               M = M + 1
+               W( M ) = D( IBEGIN )
+               WERR(M) = ZERO
+*              The gap for a single block doesn't matter for the later
+*              algorithm and is assigned an arbitrary large value
+               IBLOCK( M ) = JBLK
+               INDEXW( M ) = 1
+            END IF
+
+*        Disabled 2x2 case because of a failure on the following matrix
+*        RANGE = 'I', IL = IU = 4
+*          Original Tridiagonal, d = [
+*           -0.150102010615740E+00
+*           -0.849897989384260E+00
+*           -0.128208148052635E-15
+*            0.128257718286320E-15
+*          ];
+*          e = [
+*           -0.357171383266986E+00
+*           -0.180411241501588E-15
+*           -0.175152352710251E-15
+*          ];
+*
+*         ELSE IF( IN.EQ.2 ) THEN
+**           2x2 block
+*            DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
+*            TMP1 = HALF*(D(IBEGIN)+D(IEND))
+*            L1 = TMP1 - DISC
+*            IF( WL.GE. L1-PIVMIN )
+*     $         NWL = NWL + 1
+*            IF( WU.GE. L1-PIVMIN )
+*     $         NWU = NWU + 1
+*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
+*     $          L1-PIVMIN ) ) THEN
+*               M = M + 1
+*               W( M ) = L1
+**              The uncertainty of eigenvalues of a 2x2 matrix is very small
+*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
+*               IBLOCK( M ) = JBLK
+*               INDEXW( M ) = 1
+*            ENDIF
+*            L2 = TMP1 + DISC
+*            IF( WL.GE. L2-PIVMIN )
+*     $         NWL = NWL + 1
+*            IF( WU.GE. L2-PIVMIN )
+*     $         NWU = NWU + 1
+*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
+*     $          L2-PIVMIN ) ) THEN
+*               M = M + 1
+*               W( M ) = L2
+**              The uncertainty of eigenvalues of a 2x2 matrix is very small
+*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
+*               IBLOCK( M ) = JBLK
+*               INDEXW( M ) = 2
+*            ENDIF
+         ELSE
+*           General Case - block of size IN >= 2
+*           Compute local Gerschgorin interval and use it as the initial
+*           interval for DLAEBZ
+            GU = D( IBEGIN )
+            GL = D( IBEGIN )
+            TMP1 = ZERO
+
+            DO 40 J = IBEGIN, IEND
+               GL =  MIN( GL, GERS( 2*J - 1))
+               GU = MAX( GU, GERS(2*J) )
+   40       CONTINUE
+            SPDIAM = GU - GL
+            GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
+            GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
+*
+            IF( IRANGE.GT.1 ) THEN
+               IF( GU.LT.WL ) THEN
+*                 the local block contains none of the wanted eigenvalues
+                  NWL = NWL + IN
+                  NWU = NWU + IN
+                  GO TO 70
+               END IF
+*              refine search interval if possible, only range (WL,WU] matters
+               GL = MAX( GL, WL )
+               GU = MIN( GU, WU )
+               IF( GL.GE.GU )
+     $            GO TO 70
+            END IF
+
+*           Find negcount of initial interval boundaries GL and GU
+            WORK( N+1 ) = GL
+            WORK( N+IN+1 ) = GU
+            CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+            IF( IINFO .NE. 0 ) THEN
+               INFO = IINFO
+               RETURN
+            END IF
+*
+            NWL = NWL + IWORK( 1 )
+            NWU = NWU + IWORK( IN+1 )
+            IWOFF = M - IWORK( 1 )
+
+*           Compute Eigenvalues
+            ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+     $              LOG( TWO ) ) + 2
+            CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+            IF( IINFO .NE. 0 ) THEN
+               INFO = IINFO
+               RETURN
+            END IF
+*
+*           Copy eigenvalues into W and IBLOCK
+*           Use -JBLK for block number for unconverged eigenvalues.
+*           Loop over the number of output intervals from DLAEBZ
+            DO 60 J = 1, IOUT
+*              eigenvalue approximation is middle point of interval
+               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+*              semi length of error interval
+               TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
+               IF( J.GT.IOUT-IINFO ) THEN
+*                 Flag non-convergence.
+                  NCNVRG = .TRUE.
+                  IB = -JBLK
+               ELSE
+                  IB = JBLK
+               END IF
+               DO 50 JE = IWORK( J ) + 1 + IWOFF,
+     $                 IWORK( J+IN ) + IWOFF
+                  W( JE ) = TMP1
+                  WERR( JE ) = TMP2
+                  INDEXW( JE ) = JE - IWOFF
+                  IBLOCK( JE ) = IB
+   50          CONTINUE
+   60       CONTINUE
+*
+            M = M + IM
+         END IF
+   70 CONTINUE
+
+*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+      IF( IRANGE.EQ.INDRNG ) THEN
+         IDISCL = IL - 1 - NWL
+         IDISCU = NWU - IU
+*
+         IF( IDISCL.GT.0 ) THEN
+            IM = 0
+            DO 80 JE = 1, M
+*              Remove some of the smallest eigenvalues from the left so that
+*              at the end IDISCL =0. Move all eigenvalues up to the left.
+               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+                  IDISCL = IDISCL - 1
+               ELSE
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  WERR( IM ) = WERR( JE )
+                  INDEXW( IM ) = INDEXW( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+ 80         CONTINUE
+            M = IM
+         END IF
+         IF( IDISCU.GT.0 ) THEN
+*           Remove some of the largest eigenvalues from the right so that
+*           at the end IDISCU =0. Move all eigenvalues up to the left.
+            IM=M+1
+            DO 81 JE = M, 1, -1
+               IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+                  IDISCU = IDISCU - 1
+               ELSE
+                  IM = IM - 1
+                  W( IM ) = W( JE )
+                  WERR( IM ) = WERR( JE )
+                  INDEXW( IM ) = INDEXW( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+ 81         CONTINUE
+            JEE = 0
+            DO 82 JE = IM, M
+               JEE = JEE + 1
+               W( JEE ) = W( JE )
+               WERR( JEE ) = WERR( JE )
+               INDEXW( JEE ) = INDEXW( JE )
+               IBLOCK( JEE ) = IBLOCK( JE )
+ 82         CONTINUE
+            M = M-IM+1
+         END IF
+
+         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+*           Code to deal with effects of bad arithmetic. (If N(w) is
+*           monotone non-decreasing, this should never happen.)
+*           Some low eigenvalues to be discarded are not in (WL,WLU],
+*           or high eigenvalues to be discarded are not in (WUL,WU]
+*           so just kill off the smallest IDISCL/largest IDISCU
+*           eigenvalues, by marking the corresponding IBLOCK = 0
+            IF( IDISCL.GT.0 ) THEN
+               WKILL = WU
+               DO 100 JDISC = 1, IDISCL
+                  IW = 0
+                  DO 90 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                    ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+ 90               CONTINUE
+                  IBLOCK( IW ) = 0
+ 100           CONTINUE
+            END IF
+            IF( IDISCU.GT.0 ) THEN
+               WKILL = WL
+               DO 120 JDISC = 1, IDISCU
+                  IW = 0
+                  DO 110 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                    ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+ 110              CONTINUE
+                  IBLOCK( IW ) = 0
+ 120           CONTINUE
+            END IF
+*           Now erase all eigenvalues with IBLOCK set to zero
+            IM = 0
+            DO 130 JE = 1, M
+               IF( IBLOCK( JE ).NE.0 ) THEN
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  WERR( IM ) = WERR( JE )
+                  INDEXW( IM ) = INDEXW( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+ 130        CONTINUE
+            M = IM
+         END IF
+         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+            TOOFEW = .TRUE.
+         END IF
+      END IF
+*
+      IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
+     $   ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
+         TOOFEW = .TRUE.
+      END IF
+
+*     If ORDER='B', do nothing the eigenvalues are already sorted by
+*        block.
+*     If ORDER='E', sort the eigenvalues from smallest to largest
+
+      IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN
+         DO 150 JE = 1, M - 1
+            IE = 0
+            TMP1 = W( JE )
+            DO 140 J = JE + 1, M
+               IF( W( J ).LT.TMP1 ) THEN
+                  IE = J
+                  TMP1 = W( J )
+               END IF
+  140       CONTINUE
+            IF( IE.NE.0 ) THEN
+               TMP2 = WERR( IE )
+               ITMP1 = IBLOCK( IE )
+               ITMP2 = INDEXW( IE )
+               W( IE ) = W( JE )
+               WERR( IE ) = WERR( JE )
+               IBLOCK( IE ) = IBLOCK( JE )
+               INDEXW( IE ) = INDEXW( JE )
+               W( JE ) = TMP1
+               WERR( JE ) = TMP2
+               IBLOCK( JE ) = ITMP1
+               INDEXW( JE ) = ITMP2
+            END IF
+  150    CONTINUE
+      END IF
+*
+      INFO = 0
+      IF( NCNVRG )
+     $   INFO = INFO + 1
+      IF( TOOFEW )
+     $   INFO = INFO + 2
+      RETURN
+*
+*     End of DLARRD
+*
+      END
diff --git a/SRC/dlarre.f b/SRC/dlarre.f
new file mode 100644
index 00000000..2ba9eef5
--- /dev/null
+++ b/SRC/dlarre.f
@@ -0,0 +1,752 @@
+      SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
+     $                    RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
+     $                    W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
+     $                    WORK, IWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          RANGE
+      INTEGER            IL, INFO, IU, M, N, NSPLIT
+      DOUBLE PRECISION  PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+     $                   INDEXW( * )
+      DOUBLE PRECISION   D( * ), E( * ), E2( * ), GERS( * ),
+     $                   W( * ),WERR( * ), WGAP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  To find the desired eigenvalues of a given real symmetric
+*  tridiagonal matrix T, DLARRE sets any "small" off-diagonal
+*  elements to zero, and for each unreduced block T_i, it finds
+*  (a) a suitable shift at one end of the block's spectrum,
+*  (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
+*  (c) eigenvalues of each L_i D_i L_i^T.
+*  The representations and eigenvalues found are then used by
+*  DSTEMR to compute the eigenvectors of T.
+*  The accuracy varies depending on whether bisection is used to
+*  find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to
+*  conpute all and then discard any unwanted one.
+*  As an added benefit, DLARRE also outputs the n
+*  Gerschgorin intervals for the matrices L_i D_i L_i^T.
+*
+*  Arguments
+*  =========
+*
+*  RANGE   (input) CHARACTER
+*          = 'A': ("All")   all eigenvalues will be found.
+*          = 'V': ("Value") all eigenvalues in the half-open interval
+*                           (VL, VU] will be found.
+*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+*                           entire matrix) will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  VL      (input/output) DOUBLE PRECISION
+*  VU      (input/output) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds for the eigenvalues.
+*          Eigenvalues less than or equal to VL, or greater than VU,
+*          will not be returned.  VL < VU.
+*          If RANGE='I' or ='A', DLARRE computes bounds on the desired
+*          part of the spectrum.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal
+*          matrix T.
+*          On exit, the N diagonal elements of the diagonal
+*          matrices D_i.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the first (N-1) entries contain the subdiagonal
+*          elements of the tridiagonal matrix T; E(N) need not be set.
+*          On exit, E contains the subdiagonal elements of the unit
+*          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+*          1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+*  E2      (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the first (N-1) entries contain the SQUARES of the
+*          subdiagonal elements of the tridiagonal matrix T;
+*          E2(N) need not be set.
+*          On exit, the entries E2( ISPLIT( I ) ),
+*          1 <= I <= NSPLIT, have been set to zero
+*
+*  RTOL1   (input) DOUBLE PRECISION
+*  RTOL2   (input) DOUBLE PRECISION
+*           Parameters for bisection.
+*           An interval [LEFT,RIGHT] has converged if
+*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+*  SPLTOL (input) DOUBLE PRECISION
+*          The threshold for splitting.
+*
+*  NSPLIT  (output) INTEGER
+*          The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+*  ISPLIT  (output) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues (of all L_i D_i L_i^T)
+*          found.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the eigenvalues. The
+*          eigenvalues of each of the blocks, L_i D_i L_i^T, are
+*          sorted in ascending order ( DLARRE may use the
+*          remaining N-M elements as workspace).
+*
+*  WERR    (output) DOUBLE PRECISION array, dimension (N)
+*          The error bound on the corresponding eigenvalue in W.
+*
+*  WGAP    (output) DOUBLE PRECISION array, dimension (N)
+*          The separation from the right neighbor eigenvalue in W.
+*          The gap is only with respect to the eigenvalues of the same block
+*          as each block has its own representation tree.
+*          Exception: at the right end of a block we store the left gap
+*
+*  IBLOCK  (output) INTEGER array, dimension (N)
+*          The indices of the blocks (submatrices) associated with the
+*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+*          W(i) belongs to the first block from the top, =2 if W(i)
+*          belongs to the second block, etc.
+*
+*  INDEXW  (output) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+*          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+*  GERS    (output) DOUBLE PRECISION array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)).
+*
+*  PIVMIN  (output) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence for T.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*          Workspace.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          > 0:  A problem occured in DLARRE.
+*          < 0:  One of the called subroutines signaled an internal problem.
+*                Needs inspection of the corresponding parameter IINFO
+*                for further information.
+*
+*          =-1:  Problem in DLARRD.
+*          = 2:  No base representation could be found in MAXTRY iterations.
+*                Increasing MAXTRY and recompilation might be a remedy.
+*          =-3:  Problem in DLARRB when computing the refined root
+*                representation for DLASQ2.
+*          =-4:  Problem in DLARRB when preforming bisection on the
+*                desired part of the spectrum.
+*          =-5:  Problem in DLASQ2.
+*          =-6:  Problem in DLASQ2.
+*
+*  Further Details
+*  The base representations are required to suffer very little
+*  element growth and consequently define all their eigenvalues to
+*  high relative accuracy.
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
+     $                   MAXGROWTH, ONE, PERT, TWO, ZERO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0,
+     $                     TWO = 2.0D0, FOUR=4.0D0,
+     $                     HNDRD = 100.0D0,
+     $                     PERT = 8.0D0,
+     $                     HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
+     $                     MAXGROWTH = 64.0D0, FUDGE = 2.0D0 )
+      INTEGER            MAXTRY, ALLRNG, INDRNG, VALRNG
+      PARAMETER          ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
+     $                     VALRNG = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORCEB, NOREP, USEDQD
+      INTEGER            CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+     $                   IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+     $                   WBEGIN, WEND
+      DOUBLE PRECISION   AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
+     $                   EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
+     $                   RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
+     $                   TAU, TMP, TMP1
+
+
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION            DLAMCH
+      EXTERNAL           DLAMCH, LSAME
+
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD,
+     $                   DLASQ2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+
+*     ..
+*     .. Executable Statements ..
+*
+
+      INFO = 0
+
+*
+*     Decode RANGE
+*
+      IF( LSAME( RANGE, 'A' ) ) THEN
+         IRANGE = ALLRNG
+      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+         IRANGE = VALRNG
+      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+         IRANGE = INDRNG
+      END IF
+
+      M = 0
+
+*     Get machine constants
+      SAFMIN = DLAMCH( 'S' )
+      EPS = DLAMCH( 'P' )
+
+*     Set parameters
+      RTL = SQRT(EPS)
+      BSRTOL = SQRT(EPS)
+
+*     Treat case of 1x1 matrix for quick return
+      IF( N.EQ.1 ) THEN
+         IF( (IRANGE.EQ.ALLRNG).OR.
+     $       ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+     $       ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+            M = 1
+            W(1) = D(1)
+*           The computation error of the eigenvalue is zero
+            WERR(1) = ZERO
+            WGAP(1) = ZERO
+            IBLOCK( 1 ) = 1
+            INDEXW( 1 ) = 1
+            GERS(1) = D( 1 )
+            GERS(2) = D( 1 )
+         ENDIF
+*        store the shift for the initial RRR, which is zero in this case
+         E(1) = ZERO
+         RETURN
+      END IF
+
+*     General case: tridiagonal matrix of order > 1
+*
+*     Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
+*     Compute maximum off-diagonal entry and pivmin.
+      GL = D(1)
+      GU = D(1)
+      EOLD = ZERO
+      EMAX = ZERO
+      E(N) = ZERO
+      DO 5 I = 1,N
+         WERR(I) = ZERO
+         WGAP(I) = ZERO
+         EABS = ABS( E(I) )
+         IF( EABS .GE. EMAX ) THEN
+            EMAX = EABS
+         END IF
+         TMP1 = EABS + EOLD
+         GERS( 2*I-1) = D(I) - TMP1
+         GL =  MIN( GL, GERS( 2*I - 1))
+         GERS( 2*I ) = D(I) + TMP1
+         GU = MAX( GU, GERS(2*I) )
+         EOLD  = EABS
+ 5    CONTINUE
+*     The minimum pivot allowed in the Sturm sequence for T
+      PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
+*     Compute spectral diameter. The Gerschgorin bounds give an
+*     estimate that is wrong by at most a factor of SQRT(2)
+      SPDIAM = GU - GL
+
+*     Compute splitting points
+      CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM,
+     $                    NSPLIT, ISPLIT, IINFO )
+
+*     Can force use of bisection instead of faster DQDS.
+*     Option left in the code for future multisection work.
+      FORCEB = .FALSE.
+
+*     Initialize USEDQD, DQDS should be used for ALLRNG unless someone
+*     explicitly wants bisection.
+      USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB))
+
+      IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
+*        Set interval [VL,VU] that contains all eigenvalues
+         VL = GL
+         VU = GU
+      ELSE
+*        We call DLARRD to find crude approximations to the eigenvalues
+*        in the desired range. In case IRANGE = INDRNG, we also obtain the
+*        interval (VL,VU] that contains all the wanted eigenvalues.
+*        An interval [LEFT,RIGHT] has converged if
+*        RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
+*        DLARRD needs a WORK of size 4*N, IWORK of size 3*N
+         CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
+     $                    BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+     $                    MM, W, WERR, VL, VU, IBLOCK, INDEXW,
+     $                    WORK, IWORK, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = -1
+            RETURN
+         ENDIF
+*        Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
+         DO 14 I = MM+1,N
+            W( I ) = ZERO
+            WERR( I ) = ZERO
+            IBLOCK( I ) = 0
+            INDEXW( I ) = 0
+ 14      CONTINUE
+      END IF
+
+
+***
+*     Loop over unreduced blocks
+      IBEGIN = 1
+      WBEGIN = 1
+      DO 170 JBLK = 1, NSPLIT
+         IEND = ISPLIT( JBLK )
+         IN = IEND - IBEGIN + 1
+
+*        1 X 1 block
+         IF( IN.EQ.1 ) THEN
+            IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
+     $         ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+     $        .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
+     $        ) THEN
+               M = M + 1
+               W( M ) = D( IBEGIN )
+               WERR(M) = ZERO
+*              The gap for a single block doesn't matter for the later
+*              algorithm and is assigned an arbitrary large value
+               WGAP(M) = ZERO
+               IBLOCK( M ) = JBLK
+               INDEXW( M ) = 1
+               WBEGIN = WBEGIN + 1
+            ENDIF
+*           E( IEND ) holds the shift for the initial RRR
+            E( IEND ) = ZERO
+            IBEGIN = IEND + 1
+            GO TO 170
+         END IF
+*
+*        Blocks of size larger than 1x1
+*
+*        E( IEND ) will hold the shift for the initial RRR, for now set it =0
+         E( IEND ) = ZERO
+*
+*        Find local outer bounds GL,GU for the block
+         GL = D(IBEGIN)
+         GU = D(IBEGIN)
+         DO 15 I = IBEGIN , IEND
+            GL = MIN( GERS( 2*I-1 ), GL )
+            GU = MAX( GERS( 2*I ), GU )
+ 15      CONTINUE
+         SPDIAM = GU - GL
+
+         IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
+*           Count the number of eigenvalues in the current block.
+            MB = 0
+            DO 20 I = WBEGIN,MM
+               IF( IBLOCK(I).EQ.JBLK ) THEN
+                  MB = MB+1
+               ELSE
+                  GOTO 21
+               ENDIF
+ 20         CONTINUE
+ 21         CONTINUE
+
+            IF( MB.EQ.0) THEN
+*              No eigenvalue in the current block lies in the desired range
+*              E( IEND ) holds the shift for the initial RRR
+               E( IEND ) = ZERO
+               IBEGIN = IEND + 1
+               GO TO 170
+            ELSE
+
+*              Decide whether dqds or bisection is more efficient
+               USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
+               WEND = WBEGIN + MB - 1
+*              Calculate gaps for the current block
+*              In later stages, when representations for individual
+*              eigenvalues are different, we use SIGMA = E( IEND ).
+               SIGMA = ZERO
+               DO 30 I = WBEGIN, WEND - 1
+                  WGAP( I ) = MAX( ZERO,
+     $                        W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 30            CONTINUE
+               WGAP( WEND ) = MAX( ZERO,
+     $                     VU - SIGMA - (W( WEND )+WERR( WEND )))
+*              Find local index of the first and last desired evalue.
+               INDL = INDEXW(WBEGIN)
+               INDU = INDEXW( WEND )
+            ENDIF
+         ENDIF
+         IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
+*           Case of DQDS
+*           Find approximations to the extremal eigenvalues of the block
+            CALL DLARRK( IN, 1, GL, GU, D(IBEGIN),
+     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = -1
+               RETURN
+            ENDIF
+            ISLEFT = MAX(GL, TMP - TMP1
+     $               - HNDRD * EPS* ABS(TMP - TMP1))
+
+            CALL DLARRK( IN, IN, GL, GU, D(IBEGIN),
+     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = -1
+               RETURN
+            ENDIF
+            ISRGHT = MIN(GU, TMP + TMP1
+     $                 + HNDRD * EPS * ABS(TMP + TMP1))
+*           Improve the estimate of the spectral diameter
+            SPDIAM = ISRGHT - ISLEFT
+         ELSE
+*           Case of bisection
+*           Find approximations to the wanted extremal eigenvalues
+            ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
+     $                  - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
+            ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
+     $                  + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
+         ENDIF
+
+
+*        Decide whether the base representation for the current block
+*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
+*        should be on the left or the right end of the current block.
+*        The strategy is to shift to the end which is "more populated"
+*        Furthermore, decide whether to use DQDS for the computation of
+*        the eigenvalue approximations at the end of DLARRE or bisection.
+*        dqds is chosen if all eigenvalues are desired or the number of
+*        eigenvalues to be computed is large compared to the blocksize.
+         IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+*           If all the eigenvalues have to be computed, we use dqd
+            USEDQD = .TRUE.
+*           INDL is the local index of the first eigenvalue to compute
+            INDL = 1
+            INDU = IN
+*           MB =  number of eigenvalues to compute
+            MB = IN
+            WEND = WBEGIN + MB - 1
+*           Define 1/4 and 3/4 points of the spectrum
+            S1 = ISLEFT + FOURTH * SPDIAM
+            S2 = ISRGHT - FOURTH * SPDIAM
+         ELSE
+*           DLARRD has computed IBLOCK and INDEXW for each eigenvalue
+*           approximation.
+*           choose sigma
+            IF( USEDQD ) THEN
+               S1 = ISLEFT + FOURTH * SPDIAM
+               S2 = ISRGHT - FOURTH * SPDIAM
+            ELSE
+               TMP = MIN(ISRGHT,VU) -  MAX(ISLEFT,VL)
+               S1 =  MAX(ISLEFT,VL) + FOURTH * TMP
+               S2 =  MIN(ISRGHT,VU) - FOURTH * TMP
+            ENDIF
+         ENDIF
+
+*        Compute the negcount at the 1/4 and 3/4 points
+         IF(MB.GT.1) THEN
+            CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN),
+     $                    E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
+         ENDIF
+
+         IF(MB.EQ.1) THEN
+            SIGMA = GL
+            SGNDEF = ONE
+         ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
+            IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+               SIGMA = MAX(ISLEFT,GL)
+            ELSEIF( USEDQD ) THEN
+*              use Gerschgorin bound as shift to get pos def matrix
+*              for dqds
+               SIGMA = ISLEFT
+            ELSE
+*              use approximation of the first desired eigenvalue of the
+*              block as shift
+               SIGMA = MAX(ISLEFT,VL)
+            ENDIF
+            SGNDEF = ONE
+         ELSE
+            IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+               SIGMA = MIN(ISRGHT,GU)
+            ELSEIF( USEDQD ) THEN
+*              use Gerschgorin bound as shift to get neg def matrix
+*              for dqds
+               SIGMA = ISRGHT
+            ELSE
+*              use approximation of the first desired eigenvalue of the
+*              block as shift
+               SIGMA = MIN(ISRGHT,VU)
+            ENDIF
+            SGNDEF = -ONE
+         ENDIF
+
+
+*        An initial SIGMA has been chosen that will be used for computing
+*        T - SIGMA I = L D L^T
+*        Define the increment TAU of the shift in case the initial shift
+*        needs to be refined to obtain a factorization with not too much
+*        element growth.
+         IF( USEDQD ) THEN
+*           The initial SIGMA was to the outer end of the spectrum
+*           the matrix is definite and we need not retreat.
+            TAU = SPDIAM*EPS*N + TWO*PIVMIN
+         ELSE
+            IF(MB.GT.1) THEN
+               CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
+               AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN))
+               IF( SGNDEF.EQ.ONE ) THEN
+                  TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
+                  TAU = MAX(TAU,WERR(WBEGIN))
+               ELSE
+                  TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
+                  TAU = MAX(TAU,WERR(WEND))
+               ENDIF
+            ELSE
+               TAU = WERR(WBEGIN)
+            ENDIF
+         ENDIF
+*
+         DO 80 IDUM = 1, MAXTRY
+*           Compute L D L^T factorization of tridiagonal matrix T - sigma I.
+*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
+*           pivots in WORK(2*IN+1:3*IN)
+            DPIVOT = D( IBEGIN ) - SIGMA
+            WORK( 1 ) = DPIVOT
+            DMAX = ABS( WORK(1) )
+            J = IBEGIN
+            DO 70 I = 1, IN - 1
+               WORK( 2*IN+I ) = ONE / WORK( I )
+               TMP = E( J )*WORK( 2*IN+I )
+               WORK( IN+I ) = TMP
+               DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
+               WORK( I+1 ) = DPIVOT
+               DMAX = MAX( DMAX, ABS(DPIVOT) )
+               J = J + 1
+ 70         CONTINUE
+*           check for element growth
+            IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
+               NOREP = .TRUE.
+            ELSE
+               NOREP = .FALSE.
+            ENDIF
+            IF( USEDQD .AND. .NOT.NOREP ) THEN
+*              Ensure the definiteness of the representation
+*              All entries of D (of L D L^T) must have the same sign
+               DO 71 I = 1, IN
+                  TMP = SGNDEF*WORK( I )
+                  IF( TMP.LT.ZERO ) NOREP = .TRUE.
+ 71            CONTINUE
+            ENDIF
+            IF(NOREP) THEN
+*              Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
+*              shift which makes the matrix definite. So we should end up
+*              here really only in the case of IRANGE = VALRNG or INDRNG.
+               IF( IDUM.EQ.MAXTRY-1 ) THEN
+                  IF( SGNDEF.EQ.ONE ) THEN
+*                    The fudged Gerschgorin shift should succeed
+                     SIGMA =
+     $                    GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
+                  ELSE
+                     SIGMA =
+     $                    GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
+                  END IF
+               ELSE
+                  SIGMA = SIGMA - SGNDEF * TAU
+                  TAU = TWO * TAU
+               END IF
+            ELSE
+*              an initial RRR is found
+               GO TO 83
+            END IF
+ 80      CONTINUE
+*        if the program reaches this point, no base representation could be
+*        found in MAXTRY iterations.
+         INFO = 2
+         RETURN
+
+ 83      CONTINUE
+*        At this point, we have found an initial base representation
+*        T - SIGMA I = L D L^T with not too much element growth.
+*        Store the shift.
+         E( IEND ) = SIGMA
+*        Store D and L.
+         CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
+         CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
+
+
+         IF(MB.GT.1 ) THEN
+*
+*           Perturb each entry of the base representation by a small
+*           (but random) relative amount to overcome difficulties with
+*           glued matrices.
+*
+            DO 122 I = 1, 4
+               ISEED( I ) = 1
+ 122        CONTINUE
+
+            CALL DLARNV(2, ISEED, 2*IN-1, WORK(1))
+            DO 125 I = 1,IN-1
+               D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
+               E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
+ 125        CONTINUE
+            D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
+*
+         ENDIF
+*
+*        Don't update the Gerschgorin intervals because keeping track
+*        of the updates would be too much work in DLARRV.
+*        We update W instead and use it to locate the proper Gerschgorin
+*        intervals.
+
+*        Compute the required eigenvalues of L D L' by bisection or dqds
+         IF ( .NOT.USEDQD ) THEN
+*           If DLARRD has been used, shift the eigenvalue approximations
+*           according to their representation. This is necessary for
+*           a uniform DLARRV since dqds computes eigenvalues of the
+*           shifted representation. In DLARRV, W will always hold the
+*           UNshifted eigenvalue approximation.
+            DO 134 J=WBEGIN,WEND
+               W(J) = W(J) - SIGMA
+               WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134        CONTINUE
+*           call DLARRB to reduce eigenvalue error of the approximations
+*           from DLARRD
+            DO 135 I = IBEGIN, IEND-1
+               WORK( I ) = D( I ) * E( I )**2
+ 135        CONTINUE
+*           use bisection to find EV from INDL to INDU
+            CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN),
+     $                  INDL, INDU, RTOL1, RTOL2, INDL-1,
+     $                  W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
+     $                  WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
+     $                  IN, IINFO )
+            IF( IINFO .NE. 0 ) THEN
+               INFO = -4
+               RETURN
+            END IF
+*           DLARRB computes all gaps correctly except for the last one
+*           Record distance to VU/GU
+            WGAP( WEND ) = MAX( ZERO,
+     $           ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
+            DO 138 I = INDL, INDU
+               M = M + 1
+               IBLOCK(M) = JBLK
+               INDEXW(M) = I
+ 138        CONTINUE
+         ELSE
+*           Call dqds to get all eigs (and then possibly delete unwanted
+*           eigenvalues).
+*           Note that dqds finds the eigenvalues of the L D L^T representation
+*           of T to high relative accuracy. High relative accuracy
+*           might be lost when the shift of the RRR is subtracted to obtain
+*           the eigenvalues of T. However, T is not guaranteed to define its
+*           eigenvalues to high relative accuracy anyway.
+*           Set RTOL to the order of the tolerance used in DLASQ2
+*           This is an ESTIMATED error, the worst case bound is 4*N*EPS
+*           which is usually too large and requires unnecessary work to be
+*           done by bisection when computing the eigenvectors
+            RTOL = LOG(DBLE(IN)) * FOUR * EPS
+            J = IBEGIN
+            DO 140 I = 1, IN - 1
+               WORK( 2*I-1 ) = ABS( D( J ) )
+               WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
+               J = J + 1
+  140       CONTINUE
+            WORK( 2*IN-1 ) = ABS( D( IEND ) )
+            WORK( 2*IN ) = ZERO
+            CALL DLASQ2( IN, WORK, IINFO )
+            IF( IINFO .NE. 0 ) THEN
+*              If IINFO = -5 then an index is part of a tight cluster
+*              and should be changed. The index is in IWORK(1) and the
+*              gap is in WORK(N+1)
+               INFO = -5
+               RETURN
+            ELSE
+*              Test that all eigenvalues are positive as expected
+               DO 149 I = 1, IN
+                  IF( WORK( I ).LT.ZERO ) THEN
+                     INFO = -6
+                     RETURN
+                  ENDIF
+ 149           CONTINUE
+            END IF
+            IF( SGNDEF.GT.ZERO ) THEN
+               DO 150 I = INDL, INDU
+                  M = M + 1
+                  W( M ) = WORK( IN-I+1 )
+                  IBLOCK( M ) = JBLK
+                  INDEXW( M ) = I
+ 150           CONTINUE
+            ELSE
+               DO 160 I = INDL, INDU
+                  M = M + 1
+                  W( M ) = -WORK( I )
+                  IBLOCK( M ) = JBLK
+                  INDEXW( M ) = I
+ 160           CONTINUE
+            END IF
+
+            DO 165 I = M - MB + 1, M
+*              the value of RTOL below should be the tolerance in DLASQ2
+               WERR( I ) = RTOL * ABS( W(I) )
+ 165        CONTINUE
+            DO 166 I = M - MB + 1, M - 1
+*              compute the right gap between the intervals
+               WGAP( I ) = MAX( ZERO,
+     $                          W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 166        CONTINUE
+            WGAP( M ) = MAX( ZERO,
+     $           ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
+         END IF
+*        proceed with next block
+         IBEGIN = IEND + 1
+         WBEGIN = WEND + 1
+ 170  CONTINUE
+*
+
+      RETURN
+*
+*     end of DLARRE
+*
+      END
diff --git a/SRC/dlarrf.f b/SRC/dlarrf.f
new file mode 100644
index 00000000..f3ed1efa
--- /dev/null
+++ b/SRC/dlarrf.f
@@ -0,0 +1,373 @@
+      SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND,
+     $                   W, WGAP, WERR,
+     $                   SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
+     $                   DPLUS, LPLUS, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+**
+*     .. Scalar Arguments ..
+      INTEGER            CLSTRT, CLEND, INFO, N
+      DOUBLE PRECISION   CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), DPLUS( * ), L( * ), LD( * ),
+     $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given the initial representation L D L^T and its cluster of close
+*  eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
+*  W( CLEND ), DLARRF finds a new relatively robust representation
+*  L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
+*  eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix (subblock, if the matrix splitted).
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D.
+*
+*  L       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (N-1) subdiagonal elements of the unit bidiagonal
+*          matrix L.
+*
+*  LD      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (N-1) elements L(i)*D(i).
+*
+*  CLSTRT  (input) INTEGER
+*          The index of the first eigenvalue in the cluster.
+*
+*  CLEND   (input) INTEGER
+*          The index of the last eigenvalue in the cluster.
+*
+*  W       (input) DOUBLE PRECISION array, dimension >=  (CLEND-CLSTRT+1)
+*          The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
+*          W( CLSTRT ) through W( CLEND ) form the cluster of relatively
+*          close eigenalues.
+*
+*  WGAP    (input/output) DOUBLE PRECISION array, dimension >=  (CLEND-CLSTRT+1)
+*          The separation from the right neighbor eigenvalue in W.
+*
+*  WERR    (input) DOUBLE PRECISION array, dimension >=  (CLEND-CLSTRT+1)
+*          WERR contain the semiwidth of the uncertainty
+*          interval of the corresponding eigenvalue APPROXIMATION in W
+*
+*  SPDIAM (input) estimate of the spectral diameter obtained from the
+*          Gerschgorin intervals
+*
+*  CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
+*          Set by the calling routine to protect against shifts too close
+*          to eigenvalues outside the cluster.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence.
+*
+*  SIGMA   (output) DOUBLE PRECISION
+*          The shift used to form L(+) D(+) L(+)^T.
+*
+*  DPLUS   (output) DOUBLE PRECISION array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D(+).
+*
+*  LPLUS   (output) DOUBLE PRECISION array, dimension (N-1)
+*          The first (N-1) elements of LPLUS contain the subdiagonal
+*          elements of the unit bidiagonal matrix L(+).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
+*          Workspace.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
+     $                   ZERO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                     FOUR = 4.0D0, QUART = 0.25D0,
+     $                     MAXGROWTH1 = 8.D0,
+     $                     MAXGROWTH2 = 8.D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL   DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
+      INTEGER            I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
+      PARAMETER          ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
+      DOUBLE PRECISION   AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
+     $                   FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
+     $                   MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
+     $                   RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
+*     ..
+*     .. External Functions ..
+      LOGICAL DISNAN
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DISNAN, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      FACT = DBLE(2**KTRYMAX)
+      EPS = DLAMCH( 'Precision' )
+      SHIFT = 0
+      FORCER = .FALSE.
+
+
+*     Note that we cannot guarantee that for any of the shifts tried,
+*     the factorization has a small or even moderate element growth.
+*     There could be Ritz values at both ends of the cluster and despite
+*     backing off, there are examples where all factorizations tried
+*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE
+*     element growth.
+*     For this reason, we should use PIVMIN in this subroutine so that at
+*     least the L D L^T factorization exists. It can be checked afterwards
+*     whether the element growth caused bad residuals/orthogonality.
+
+*     Decide whether the code should accept the best among all
+*     representations despite large element growth or signal INFO=1
+      NOFAIL = .TRUE.
+*
+
+*     Compute the average gap length of the cluster
+      CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
+      AVGAP = CLWDTH / DBLE(CLEND-CLSTRT)
+      MINGAP = MIN(CLGAPL, CLGAPR)
+*     Initial values for shifts to both ends of cluster
+      LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
+      RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
+
+*     Use a small fudge to make sure that we really shift to the outside
+      LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS
+      RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS
+
+*     Compute upper bounds for how much to back off the initial shifts
+      LDMAX = QUART * MINGAP + TWO * PIVMIN
+      RDMAX = QUART * MINGAP + TWO * PIVMIN
+
+      LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
+      RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
+*
+*     Initialize the record of the best representation found
+*
+      S = DLAMCH( 'S' )
+      SMLGROWTH = ONE / S
+      FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS)
+      FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
+      BESTSHIFT = LSIGMA
+*
+*     while (KTRY <= KTRYMAX)
+      KTRY = 0
+      GROWTHBOUND = MAXGROWTH1*SPDIAM
+
+ 5    CONTINUE
+      SAWNAN1 = .FALSE.
+      SAWNAN2 = .FALSE.
+*     Ensure that we do not back off too much of the initial shifts
+      LDELTA = MIN(LDMAX,LDELTA)
+      RDELTA = MIN(RDMAX,RDELTA)
+
+*     Compute the element growth when shifting to both ends of the cluster
+*     accept the shift if there is no element growth at one of the two ends
+
+*     Left end
+      S = -LSIGMA
+      DPLUS( 1 ) = D( 1 ) + S
+      IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
+         DPLUS(1) = -PIVMIN
+*        Need to set SAWNAN1 because refined RRR test should not be used
+*        in this case
+         SAWNAN1 = .TRUE.
+      ENDIF
+      MAX1 = ABS( DPLUS( 1 ) )
+      DO 6 I = 1, N - 1
+         LPLUS( I ) = LD( I ) / DPLUS( I )
+         S = S*LPLUS( I )*L( I ) - LSIGMA
+         DPLUS( I+1 ) = D( I+1 ) + S
+         IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
+            DPLUS(I+1) = -PIVMIN
+*           Need to set SAWNAN1 because refined RRR test should not be used
+*           in this case
+            SAWNAN1 = .TRUE.
+         ENDIF
+         MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 6    CONTINUE
+      SAWNAN1 = SAWNAN1 .OR.  DISNAN( MAX1 )
+
+      IF( FORCER .OR.
+     $   (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
+         SIGMA = LSIGMA
+         SHIFT = SLEFT
+         GOTO 100
+      ENDIF
+
+*     Right end
+      S = -RSIGMA
+      WORK( 1 ) = D( 1 ) + S
+      IF(ABS(WORK(1)).LT.PIVMIN) THEN
+         WORK(1) = -PIVMIN
+*        Need to set SAWNAN2 because refined RRR test should not be used
+*        in this case
+         SAWNAN2 = .TRUE.
+      ENDIF
+      MAX2 = ABS( WORK( 1 ) )
+      DO 7 I = 1, N - 1
+         WORK( N+I ) = LD( I ) / WORK( I )
+         S = S*WORK( N+I )*L( I ) - RSIGMA
+         WORK( I+1 ) = D( I+1 ) + S
+         IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
+            WORK(I+1) = -PIVMIN
+*           Need to set SAWNAN2 because refined RRR test should not be used
+*           in this case
+            SAWNAN2 = .TRUE.
+         ENDIF
+         MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
+ 7    CONTINUE
+      SAWNAN2 = SAWNAN2 .OR.  DISNAN( MAX2 )
+
+      IF( FORCER .OR.
+     $   (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
+         SIGMA = RSIGMA
+         SHIFT = SRIGHT
+         GOTO 100
+      ENDIF
+*     If we are at this point, both shifts led to too much element growth
+
+*     Record the better of the two shifts (provided it didn't lead to NaN)
+      IF(SAWNAN1.AND.SAWNAN2) THEN
+*        both MAX1 and MAX2 are NaN
+         GOTO 50
+      ELSE
+         IF( .NOT.SAWNAN1 ) THEN
+            INDX = 1
+            IF(MAX1.LE.SMLGROWTH) THEN
+               SMLGROWTH = MAX1
+               BESTSHIFT = LSIGMA
+            ENDIF
+         ENDIF
+         IF( .NOT.SAWNAN2 ) THEN
+            IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
+            IF(MAX2.LE.SMLGROWTH) THEN
+               SMLGROWTH = MAX2
+               BESTSHIFT = RSIGMA
+            ENDIF
+         ENDIF
+      ENDIF
+
+*     If we are here, both the left and the right shift led to
+*     element growth. If the element growth is moderate, then
+*     we may still accept the representation, if it passes a
+*     refined test for RRR. This test supposes that no NaN occurred.
+*     Moreover, we use the refined RRR test only for isolated clusters.
+      IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND.
+     $   (MIN(MAX1,MAX2).LT.FAIL2)
+     $  .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
+         DORRR1 = .TRUE.
+      ELSE
+         DORRR1 = .FALSE.
+      ENDIF
+      TRYRRR1 = .TRUE.
+      IF( TRYRRR1 .AND. DORRR1 ) THEN
+      IF(INDX.EQ.1) THEN
+         TMP = ABS( DPLUS( N ) )
+         ZNM2 = ONE
+         PROD = ONE
+         OLDP = ONE
+         DO 15 I = N-1, 1, -1
+            IF( PROD .LE. EPS ) THEN
+               PROD =
+     $         ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
+            ELSE
+               PROD = PROD*ABS(WORK(N+I))
+            END IF
+            OLDP = PROD
+            ZNM2 = ZNM2 + PROD**2
+            TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
+ 15      CONTINUE
+         RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+         IF (RRR1.LE.MAXGROWTH2) THEN
+            SIGMA = LSIGMA
+            SHIFT = SLEFT
+            GOTO 100
+         ENDIF
+      ELSE IF(INDX.EQ.2) THEN
+         TMP = ABS( WORK( N ) )
+         ZNM2 = ONE
+         PROD = ONE
+         OLDP = ONE
+         DO 16 I = N-1, 1, -1
+            IF( PROD .LE. EPS ) THEN
+               PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
+            ELSE
+               PROD = PROD*ABS(LPLUS(I))
+            END IF
+            OLDP = PROD
+            ZNM2 = ZNM2 + PROD**2
+            TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
+ 16      CONTINUE
+         RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+         IF (RRR2.LE.MAXGROWTH2) THEN
+            SIGMA = RSIGMA
+            SHIFT = SRIGHT
+            GOTO 100
+         ENDIF
+      END IF
+      ENDIF
+
+ 50   CONTINUE
+
+      IF (KTRY.LT.KTRYMAX) THEN
+*        If we are here, both shifts failed also the RRR test.
+*        Back off to the outside
+         LSIGMA = MAX( LSIGMA - LDELTA,
+     $     LSIGMA - LDMAX)
+         RSIGMA = MIN( RSIGMA + RDELTA,
+     $     RSIGMA + RDMAX )
+         LDELTA = TWO * LDELTA
+         RDELTA = TWO * RDELTA
+         KTRY = KTRY + 1
+         GOTO 5
+      ELSE
+*        None of the representations investigated satisfied our
+*        criteria. Take the best one we found.
+         IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
+            LSIGMA = BESTSHIFT
+            RSIGMA = BESTSHIFT
+            FORCER = .TRUE.
+            GOTO 5
+         ELSE
+            INFO = 1
+            RETURN
+         ENDIF
+      END IF
+
+ 100  CONTINUE
+      IF (SHIFT.EQ.SLEFT) THEN
+      ELSEIF (SHIFT.EQ.SRIGHT) THEN
+*        store new L and D back into DPLUS, LPLUS
+         CALL DCOPY( N, WORK, 1, DPLUS, 1 )
+         CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
+      ENDIF
+
+      RETURN
+*
+*     End of DLARRF
+*
+      END
diff --git a/SRC/dlarrj.f b/SRC/dlarrj.f
new file mode 100644
index 00000000..54165837
--- /dev/null
+++ b/SRC/dlarrj.f
@@ -0,0 +1,280 @@
+      SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
+     $                   RTOL, OFFSET, W, WERR, WORK, IWORK,
+     $                   PIVMIN, SPDIAM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IFIRST, ILAST, INFO, N, OFFSET
+      DOUBLE PRECISION   PIVMIN, RTOL, SPDIAM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E2( * ), W( * ),
+     $                   WERR( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given the initial eigenvalue approximations of T, DLARRJ
+*  does  bisection to refine the eigenvalues of T,
+*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+*  guesses for these eigenvalues are input in W, the corresponding estimate
+*  of the error in these guesses in WERR. During bisection, intervals
+*  [left, right] are maintained by storing their mid-points and
+*  semi-widths in the arrays W and WERR respectively.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The N diagonal elements of T.
+*
+*  E2      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The Squares of the (N-1) subdiagonal elements of T.
+*
+*  IFIRST  (input) INTEGER
+*          The index of the first eigenvalue to be computed.
+*
+*  ILAST   (input) INTEGER
+*          The index of the last eigenvalue to be computed.
+*
+*  RTOL   (input) DOUBLE PRECISION
+*          Tolerance for the convergence of the bisection intervals.
+*          An interval [LEFT,RIGHT] has converged if
+*          RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
+*
+*  OFFSET  (input) INTEGER
+*          Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
+*          through ILAST-OFFSET elements of these arrays are to be used.
+*
+*  W       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+*          estimates of the eigenvalues of L D L^T indexed IFIRST through
+*          ILAST.
+*          On output, these estimates are refined.
+*
+*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)
+*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+*          the errors in the estimates of the corresponding elements in W.
+*          On output, these errors are refined.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*N)
+*          Workspace.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence for T.
+*
+*  SPDIAM  (input) DOUBLE PRECISION
+*          The spectral diameter of T.
+*
+*  INFO    (output) INTEGER
+*          Error flag.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, HALF
+      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   HALF = 0.5D0 )
+      INTEGER   MAXITR
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
+     $                   OLNINT, P, PREV, SAVI1
+      DOUBLE PRECISION   DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
+*
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+      MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+*
+*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+*     for an unconverged interval is set to the index of the next unconverged
+*     interval, and is -1 or 0 for a converged interval. Thus a linked
+*     list of unconverged intervals is set up.
+*
+
+      I1 = IFIRST
+      I2 = ILAST
+*     The number of unconverged intervals
+      NINT = 0
+*     The last unconverged interval found
+      PREV = 0
+      DO 75 I = I1, I2
+         K = 2*I
+         II = I - OFFSET
+         LEFT = W( II ) - WERR( II )
+         MID = W(II)
+         RIGHT = W( II ) + WERR( II )
+         WIDTH = RIGHT - MID
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+*        The following test prevents the test of converged intervals
+         IF( WIDTH.LT.RTOL*TMP ) THEN
+*           This interval has already converged and does not need refinement.
+*           (Note that the gaps might change through refining the
+*            eigenvalues, however, they can only get bigger.)
+*           Remove it from the list.
+            IWORK( K-1 ) = -1
+*           Make sure that I1 always points to the first unconverged interval
+            IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
+            IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
+         ELSE
+*           unconverged interval found
+            PREV = I
+*           Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+*
+*           Do while( CNT(LEFT).GT.I-1 )
+*
+            FAC = ONE
+ 20         CONTINUE
+            CNT = 0
+            S = LEFT
+            DPLUS = D( 1 ) - S
+            IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+            DO 30 J = 2, N
+               DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+               IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 30         CONTINUE
+            IF( CNT.GT.I-1 ) THEN
+               LEFT = LEFT - WERR( II )*FAC
+               FAC = TWO*FAC
+               GO TO 20
+            END IF
+*
+*           Do while( CNT(RIGHT).LT.I )
+*
+            FAC = ONE
+ 50         CONTINUE
+            CNT = 0
+            S = RIGHT
+            DPLUS = D( 1 ) - S
+            IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+            DO 60 J = 2, N
+               DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+               IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 60         CONTINUE
+            IF( CNT.LT.I ) THEN
+               RIGHT = RIGHT + WERR( II )*FAC
+               FAC = TWO*FAC
+               GO TO 50
+            END IF
+            NINT = NINT + 1
+            IWORK( K-1 ) = I + 1
+            IWORK( K ) = CNT
+         END IF
+         WORK( K-1 ) = LEFT
+         WORK( K ) = RIGHT
+ 75   CONTINUE
+
+
+      SAVI1 = I1
+*
+*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+*     and while (ITER.LT.MAXITR)
+*
+      ITER = 0
+ 80   CONTINUE
+      PREV = I1 - 1
+      I = I1
+      OLNINT = NINT
+
+      DO 100 P = 1, OLNINT
+         K = 2*I
+         II = I - OFFSET
+         NEXT = IWORK( K-1 )
+         LEFT = WORK( K-1 )
+         RIGHT = WORK( K )
+         MID = HALF*( LEFT + RIGHT )
+
+*        semiwidth of interval
+         WIDTH = RIGHT - MID
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+         IF( ( WIDTH.LT.RTOL*TMP ) .OR.
+     $      (ITER.EQ.MAXITR) )THEN
+*           reduce number of unconverged intervals
+            NINT = NINT - 1
+*           Mark interval as converged.
+            IWORK( K-1 ) = 0
+            IF( I1.EQ.I ) THEN
+               I1 = NEXT
+            ELSE
+*              Prev holds the last unconverged interval previously examined
+               IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+            END IF
+            I = NEXT
+            GO TO 100
+         END IF
+         PREV = I
+*
+*        Perform one bisection step
+*
+         CNT = 0
+         S = MID
+         DPLUS = D( 1 ) - S
+         IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+         DO 90 J = 2, N
+            DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+            IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 90      CONTINUE
+         IF( CNT.LE.I-1 ) THEN
+            WORK( K-1 ) = MID
+         ELSE
+            WORK( K ) = MID
+         END IF
+         I = NEXT
+
+ 100  CONTINUE
+      ITER = ITER + 1
+*     do another loop if there are still unconverged intervals
+*     However, in the last iteration, all intervals are accepted
+*     since this is the best we can do.
+      IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+*     At this point, all the intervals have converged
+      DO 110 I = SAVI1, ILAST
+         K = 2*I
+         II = I - OFFSET
+*        All intervals marked by '0' have been refined.
+         IF( IWORK( K-1 ).EQ.0 ) THEN
+            W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+            WERR( II ) = WORK( K ) - W( II )
+         END IF
+ 110  CONTINUE
+*
+
+      RETURN
+*
+*     End of DLARRJ
+*
+      END
diff --git a/SRC/dlarrk.f b/SRC/dlarrk.f
new file mode 100644
index 00000000..2176e4d7
--- /dev/null
+++ b/SRC/dlarrk.f
@@ -0,0 +1,166 @@
+      SUBROUTINE DLARRK( N, IW, GL, GU,
+     $                    D, E2, PIVMIN, RELTOL, W, WERR, INFO)
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER   INFO, IW, N
+      DOUBLE PRECISION    PIVMIN, RELTOL, GL, GU, W, WERR
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARRK computes one eigenvalue of a symmetric tridiagonal
+*  matrix T to suitable accuracy. This is an auxiliary code to be
+*  called from DSTEMR.
+*
+*  To avoid overflow, the matrix must be scaled so that its
+*  largest element is no greater than overflow**(1/2) *
+*  underflow**(1/4) in absolute value, and for greatest
+*  accuracy, it should not be much smaller than that.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal matrix T.  N >= 0.
+*
+*  IW      (input) INTEGER
+*          The index of the eigenvalues to be returned.
+*
+*  GL      (input) DOUBLE PRECISION
+*  GU      (input) DOUBLE PRECISION
+*          An upper and a lower bound on the eigenvalue.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E2      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence for T.
+*
+*  RELTOL  (input) DOUBLE PRECISION
+*          The minimum relative width of an interval.  When an interval
+*          is narrower than RELTOL times the larger (in
+*          magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  Note: this should
+*          always be at least radix*machine epsilon.
+*
+*  W       (output) DOUBLE PRECISION
+*
+*  WERR    (output) DOUBLE PRECISION
+*          The error bound on the corresponding eigenvalue approximation
+*          in W.
+*
+*  INFO    (output) INTEGER
+*          = 0:       Eigenvalue converged
+*          = -1:      Eigenvalue did NOT converge
+*
+*  Internal Parameters
+*  ===================
+*
+*  FUDGE   DOUBLE PRECISION, default = 2
+*          A "fudge factor" to widen the Gershgorin intervals.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   FUDGE, HALF, TWO, ZERO
+      PARAMETER          ( HALF = 0.5D0, TWO = 2.0D0,
+     $                     FUDGE = TWO, ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER   I, IT, ITMAX, NEGCNT
+      DOUBLE PRECISION   ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
+     $                   TMP2, TNORM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL   DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Get machine constants
+      EPS = DLAMCH( 'P' )
+
+      TNORM = MAX( ABS( GL ), ABS( GU ) )
+      RTOLI = RELTOL
+      ATOLI = FUDGE*TWO*PIVMIN
+
+      ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+
+      INFO = -1
+
+      LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+      RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+      IT = 0
+
+ 10   CONTINUE
+*
+*     Check if interval converged or maximum number of iterations reached
+*
+      TMP1 = ABS( RIGHT - LEFT )
+      TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
+      IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
+         INFO = 0
+         GOTO 30
+      ENDIF
+      IF(IT.GT.ITMAX)
+     $   GOTO 30
+
+*
+*     Count number of negative pivots for mid-point
+*
+      IT = IT + 1
+      MID = HALF * (LEFT + RIGHT)
+      NEGCNT = 0
+      TMP1 = D( 1 ) - MID
+      IF( ABS( TMP1 ).LT.PIVMIN )
+     $   TMP1 = -PIVMIN
+      IF( TMP1.LE.ZERO )
+     $   NEGCNT = NEGCNT + 1
+*
+      DO 20 I = 2, N
+         TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
+         IF( ABS( TMP1 ).LT.PIVMIN )
+     $      TMP1 = -PIVMIN
+         IF( TMP1.LE.ZERO )
+     $      NEGCNT = NEGCNT + 1
+ 20   CONTINUE
+
+      IF(NEGCNT.GE.IW) THEN
+         RIGHT = MID
+      ELSE
+         LEFT = MID
+      ENDIF
+      GOTO 10
+
+ 30   CONTINUE
+*
+*     Converged or maximum number of iterations reached
+*
+      W = HALF * (LEFT + RIGHT)
+      WERR = HALF * ABS( RIGHT - LEFT )
+
+      RETURN
+*
+*     End of DLARRK
+*
+      END
diff --git a/SRC/dlarrr.f b/SRC/dlarrr.f
new file mode 100644
index 00000000..1cc131e9
--- /dev/null
+++ b/SRC/dlarrr.f
@@ -0,0 +1,145 @@
+      SUBROUTINE DLARRR( N, D, E, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N, INFO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+*     ..
+*
+*
+*  Purpose
+*  =======
+*
+*  Perform tests to decide whether the symmetric tridiagonal matrix T
+*  warrants expensive computations which guarantee high relative accuracy
+*  in the eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The N diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the first (N-1) entries contain the subdiagonal
+*          elements of the tridiagonal matrix T; E(N) is set to ZERO.
+*
+*  INFO    (output) INTEGER
+*          INFO = 0(default) : the matrix warrants computations preserving
+*                              relative accuracy.
+*          INFO = 1          : the matrix warrants computations guaranteeing
+*                              only absolute accuracy.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, RELCOND
+      PARAMETER          ( ZERO = 0.0D0,
+     $                     RELCOND = 0.999D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      LOGICAL            YESREL
+      DOUBLE PRECISION   EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
+     $          OFFDIG, OFFDIG2
+
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     As a default, do NOT go for relative-accuracy preserving computations.
+      INFO = 1
+
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      RMIN = SQRT( SMLNUM )
+
+*     Tests for relative accuracy
+*
+*     Test for scaled diagonal dominance
+*     Scale the diagonal entries to one and check whether the sum of the
+*     off-diagonals is less than one
+*
+*     The sdd relative error bounds have a 1/(1- 2*x) factor in them,
+*     x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
+*     accuracy is promised.  In the notation of the code fragment below,
+*     1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
+*     We don't think it is worth going into "sdd mode" unless the relative
+*     condition number is reasonable, not 1/macheps.
+*     The threshold should be compatible with other thresholds used in the
+*     code. We set  OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
+*     to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
+*     instead of the current OFFDIG + OFFDIG2 < 1
+*
+      YESREL = .TRUE.
+      OFFDIG = ZERO
+      TMP = SQRT(ABS(D(1)))
+      IF (TMP.LT.RMIN) YESREL = .FALSE.
+      IF(.NOT.YESREL) GOTO 11
+      DO 10 I = 2, N
+         TMP2 = SQRT(ABS(D(I)))
+         IF (TMP2.LT.RMIN) YESREL = .FALSE.
+         IF(.NOT.YESREL) GOTO 11
+         OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
+         IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
+         IF(.NOT.YESREL) GOTO 11
+         TMP = TMP2
+         OFFDIG = OFFDIG2
+ 10   CONTINUE
+ 11   CONTINUE
+
+      IF( YESREL ) THEN
+         INFO = 0
+         RETURN
+      ELSE
+      ENDIF
+*
+
+*
+*     *** MORE TO BE IMPLEMENTED ***
+*
+
+*
+*     Test if the lower bidiagonal matrix L from T = L D L^T
+*     (zero shift facto) is well conditioned
+*
+
+*
+*     Test if the upper bidiagonal matrix U from T = U D U^T
+*     (zero shift facto) is well conditioned.
+*     In this case, the matrix needs to be flipped and, at the end
+*     of the eigenvector computation, the flip needs to be applied
+*     to the computed eigenvectors (and the support)
+*
+
+*
+      RETURN
+*
+*     END OF DLARRR
+*
+      END
diff --git a/SRC/dlarrv.f b/SRC/dlarrv.f
new file mode 100644
index 00000000..95d8d6d7
--- /dev/null
+++ b/SRC/dlarrv.f
@@ -0,0 +1,895 @@
+      SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN,
+     $                   ISPLIT, M, DOL, DOU, MINRGP,
+     $                   RTOL1, RTOL2, W, WERR, WGAP,
+     $                   IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            DOL, DOU, INFO, LDZ, M, N
+      DOUBLE PRECISION   MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+     $                   ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
+     $                   WGAP( * ), WORK( * )
+      DOUBLE PRECISION  Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARRV computes the eigenvectors of the tridiagonal matrix
+*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
+*  The input eigenvalues should have been computed by DLARRE.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          Lower and upper bounds of the interval that contains the desired
+*          eigenvalues. VL < VU. Needed to compute gaps on the left or right
+*          end of the extremal eigenvalues in the desired RANGE.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the diagonal matrix D.
+*          On exit, D may be overwritten.
+*
+*  L       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the unit
+*          bidiagonal matrix L are in elements 1 to N-1 of L
+*          (if the matrix is not splitted.) At the end of each block
+*          is stored the corresponding shift as given by DLARRE.
+*          On exit, L is overwritten.
+*
+*  PIVMIN  (in) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence.
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*
+*  M       (input) INTEGER
+*          The total number of input eigenvalues.  0 <= M <= N.
+*
+*  DOL     (input) INTEGER
+*  DOU     (input) INTEGER
+*          If the user wants to compute only selected eigenvectors from all
+*          the eigenvalues supplied, he can specify an index range DOL:DOU.
+*          Or else the setting DOL=1, DOU=M should be applied.
+*          Note that DOL and DOU refer to the order in which the eigenvalues
+*          are stored in W.
+*          If the user wants to compute only selected eigenpairs, then
+*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+*          computed eigenvectors. All other columns of Z are set to zero.
+*
+*  MINRGP  (input) DOUBLE PRECISION
+*
+*  RTOL1   (input) DOUBLE PRECISION
+*  RTOL2   (input) DOUBLE PRECISION
+*           Parameters for bisection.
+*           An interval [LEFT,RIGHT] has converged if
+*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+*  W       (input/output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements of W contain the APPROXIMATE eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block ( The output array
+*          W from DLARRE is expected here ). Furthermore, they are with
+*          respect to the shift of the corresponding root representation
+*          for their block. On exit, W holds the eigenvalues of the
+*          UNshifted matrix.
+*
+*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the semiwidth of the uncertainty
+*          interval of the corresponding eigenvalue in W
+*
+*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N)
+*          The separation from the right neighbor eigenvalue in W.
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The indices of the blocks (submatrices) associated with the
+*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+*          W(i) belongs to the first block from the top, =2 if W(i)
+*          belongs to the second block, etc.
+*
+*  INDEXW  (input) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+*  GERS    (input) DOUBLE PRECISION array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+*          be computed from the original UNshifted matrix.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+*          If INFO = 0, the first M columns of Z contain the
+*          orthonormal eigenvectors of the matrix T
+*          corresponding to the input eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The I-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*I-1 ) through
+*          ISUPPZ( 2*I ).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (12*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (7*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*
+*          > 0:  A problem occured in DLARRV.
+*          < 0:  One of the called subroutines signaled an internal problem.
+*                Needs inspection of the corresponding parameter IINFO
+*                for further information.
+*
+*          =-1:  Problem in DLARRB when refining a child's eigenvalues.
+*          =-2:  Problem in DLARRF when computing the RRR of a child.
+*                When a child is inside a tight cluster, it can be difficult
+*                to find an RRR. A partial remedy from the user's point of
+*                view is to make the parameter MINRGP smaller and recompile.
+*                However, as the orthogonality of the computed vectors is
+*                proportional to 1/MINRGP, the user should be aware that
+*                he might be trading in precision when he decreases MINRGP.
+*          =-3:  Problem in DLARRB when refining a single eigenvalue
+*                after the Rayleigh correction was rejected.
+*          = 5:  The Rayleigh Quotient Iteration failed to converge to
+*                full accuracy in MAXITR steps.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXITR
+      PARAMETER          ( MAXITR = 10 )
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, HALF
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0,
+     $                     TWO = 2.0D0, THREE = 3.0D0,
+     $                     FOUR = 4.0D0, HALF = 0.5D0)
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
+      INTEGER            DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
+     $                   IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
+     $                   INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
+     $                   ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
+     $                   NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
+     $                   NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
+     $                   OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
+     $                   WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
+     $                   ZUSEDW
+      DOUBLE PRECISION   BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
+     $                   LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
+     $                   RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
+     $                   SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAR1V, DLARRB, DLARRF, DLASET,
+     $                   DSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS, DBLE, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*     ..
+
+*     The first N entries of WORK are reserved for the eigenvalues
+      INDLD = N+1
+      INDLLD= 2*N+1
+      INDWRK= 3*N+1
+      MINWSIZE = 12 * N
+
+      DO 5 I= 1,MINWSIZE
+         WORK( I ) = ZERO
+ 5    CONTINUE
+
+*     IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
+*     factorization used to compute the FP vector
+      IINDR = 0
+*     IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
+*     layer and the one above.
+      IINDC1 = N
+      IINDC2 = 2*N
+      IINDWK = 3*N + 1
+
+      MINIWSIZE = 7 * N
+      DO 10 I= 1,MINIWSIZE
+         IWORK( I ) = 0
+ 10   CONTINUE
+
+      ZUSEDL = 1
+      IF(DOL.GT.1) THEN
+*        Set lower bound for use of Z
+         ZUSEDL = DOL-1
+      ENDIF
+      ZUSEDU = M
+      IF(DOU.LT.M) THEN
+*        Set lower bound for use of Z
+         ZUSEDU = DOU+1
+      ENDIF
+*     The width of the part of Z that is used
+      ZUSEDW = ZUSEDU - ZUSEDL + 1
+
+
+      CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
+     $                    Z(1,ZUSEDL), LDZ )
+
+      EPS = DLAMCH( 'Precision' )
+      RQTOL = TWO * EPS
+*
+*     Set expert flags for standard code.
+      TRYRQC = .TRUE.
+
+      IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+      ELSE
+*        Only selected eigenpairs are computed. Since the other evalues
+*        are not refined by RQ iteration, bisection has to compute to full
+*        accuracy.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ENDIF
+
+*     The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
+*     desired eigenvalues. The support of the nonzero eigenvector
+*     entries is contained in the interval IBEGIN:IEND.
+*     Remark that if k eigenpairs are desired, then the eigenvectors
+*     are stored in k contiguous columns of Z.
+
+*     DONE is the number of eigenvectors already computed
+      DONE = 0
+      IBEGIN = 1
+      WBEGIN = 1
+      DO 170 JBLK = 1, IBLOCK( M )
+         IEND = ISPLIT( JBLK )
+         SIGMA = L( IEND )
+*        Find the eigenvectors of the submatrix indexed IBEGIN
+*        through IEND.
+         WEND = WBEGIN - 1
+ 15      CONTINUE
+         IF( WEND.LT.M ) THEN
+            IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+               WEND = WEND + 1
+               GO TO 15
+            END IF
+         END IF
+         IF( WEND.LT.WBEGIN ) THEN
+            IBEGIN = IEND + 1
+            GO TO 170
+         ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+            GO TO 170
+         END IF
+
+*        Find local spectral diameter of the block
+         GL = GERS( 2*IBEGIN-1 )
+         GU = GERS( 2*IBEGIN )
+         DO 20 I = IBEGIN+1 , IEND
+            GL = MIN( GERS( 2*I-1 ), GL )
+            GU = MAX( GERS( 2*I ), GU )
+ 20      CONTINUE
+         SPDIAM = GU - GL
+
+*        OLDIEN is the last index of the previous block
+         OLDIEN = IBEGIN - 1
+*        Calculate the size of the current block
+         IN = IEND - IBEGIN + 1
+*        The number of eigenvalues in the current block
+         IM = WEND - WBEGIN + 1
+
+*        This is for a 1x1 block
+         IF( IBEGIN.EQ.IEND ) THEN
+            DONE = DONE+1
+            Z( IBEGIN, WBEGIN ) = ONE
+            ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
+            ISUPPZ( 2*WBEGIN ) = IBEGIN
+            W( WBEGIN ) = W( WBEGIN ) + SIGMA
+            WORK( WBEGIN ) = W( WBEGIN )
+            IBEGIN = IEND + 1
+            WBEGIN = WBEGIN + 1
+            GO TO 170
+         END IF
+
+*        The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
+*        Note that these can be approximations, in this case, the corresp.
+*        entries of WERR give the size of the uncertainty interval.
+*        The eigenvalue approximations will be refined when necessary as
+*        high relative accuracy is required for the computation of the
+*        corresponding eigenvectors.
+         CALL DCOPY( IM, W( WBEGIN ), 1,
+     &                   WORK( WBEGIN ), 1 )
+
+*        We store in W the eigenvalue approximations w.r.t. the original
+*        matrix T.
+         DO 30 I=1,IM
+            W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 30      CONTINUE
+
+
+*        NDEPTH is the current depth of the representation tree
+         NDEPTH = 0
+*        PARITY is either 1 or 0
+         PARITY = 1
+*        NCLUS is the number of clusters for the next level of the
+*        representation tree, we start with NCLUS = 1 for the root
+         NCLUS = 1
+         IWORK( IINDC1+1 ) = 1
+         IWORK( IINDC1+2 ) = IM
+
+*        IDONE is the number of eigenvectors already computed in the current
+*        block
+         IDONE = 0
+*        loop while( IDONE.LT.IM )
+*        generate the representation tree for the current block and
+*        compute the eigenvectors
+   40    CONTINUE
+         IF( IDONE.LT.IM ) THEN
+*           This is a crude protection against infinitely deep trees
+            IF( NDEPTH.GT.M ) THEN
+               INFO = -2
+               RETURN
+            ENDIF
+*           breadth first processing of the current level of the representation
+*           tree: OLDNCL = number of clusters on current level
+            OLDNCL = NCLUS
+*           reset NCLUS to count the number of child clusters
+            NCLUS = 0
+*
+            PARITY = 1 - PARITY
+            IF( PARITY.EQ.0 ) THEN
+               OLDCLS = IINDC1
+               NEWCLS = IINDC2
+            ELSE
+               OLDCLS = IINDC2
+               NEWCLS = IINDC1
+            END IF
+*           Process the clusters on the current level
+            DO 150 I = 1, OLDNCL
+               J = OLDCLS + 2*I
+*              OLDFST, OLDLST = first, last index of current cluster.
+*                               cluster indices start with 1 and are relative
+*                               to WBEGIN when accessing W, WGAP, WERR, Z
+               OLDFST = IWORK( J-1 )
+               OLDLST = IWORK( J )
+               IF( NDEPTH.GT.0 ) THEN
+*                 Retrieve relatively robust representation (RRR) of cluster
+*                 that has been computed at the previous level
+*                 The RRR is stored in Z and overwritten once the eigenvectors
+*                 have been computed or when the cluster is refined
+
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Get representation from location of the leftmost evalue
+*                    of the cluster
+                     J = WBEGIN + OLDFST - 1
+                  ELSE
+                     IF(WBEGIN+OLDFST-1.LT.DOL) THEN
+*                       Get representation from the left end of Z array
+                        J = DOL - 1
+                     ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
+*                       Get representation from the right end of Z array
+                        J = DOU
+                     ELSE
+                        J = WBEGIN + OLDFST - 1
+                     ENDIF
+                  ENDIF
+                  CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
+                  CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
+     $               1 )
+                  SIGMA = Z( IEND, J+1 )
+
+*                 Set the corresponding entries in Z to zero
+                  CALL DLASET( 'Full', IN, 2, ZERO, ZERO,
+     $                         Z( IBEGIN, J), LDZ )
+               END IF
+
+*              Compute DL and DLL of current RRR
+               DO 50 J = IBEGIN, IEND-1
+                  TMP = D( J )*L( J )
+                  WORK( INDLD-1+J ) = TMP
+                  WORK( INDLLD-1+J ) = TMP*L( J )
+   50          CONTINUE
+
+               IF( NDEPTH.GT.0 ) THEN
+*                 P and Q are index of the first and last eigenvalue to compute
+*                 within the current block
+                  P = INDEXW( WBEGIN-1+OLDFST )
+                  Q = INDEXW( WBEGIN-1+OLDLST )
+*                 Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
+*                 thru' Q-OFFSET elements of these arrays are to be used.
+C                  OFFSET = P-OLDFST
+                  OFFSET = INDEXW( WBEGIN ) - 1
+*                 perform limited bisection (if necessary) to get approximate
+*                 eigenvalues to the precision needed.
+                  CALL DLARRB( IN, D( IBEGIN ),
+     $                         WORK(INDLLD+IBEGIN-1),
+     $                         P, Q, RTOL1, RTOL2, OFFSET,
+     $                         WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+     $                         WORK( INDWRK ), IWORK( IINDWK ),
+     $                         PIVMIN, SPDIAM, IN, IINFO )
+                  IF( IINFO.NE.0 ) THEN
+                     INFO = -1
+                     RETURN
+                  ENDIF
+*                 We also recompute the extremal gaps. W holds all eigenvalues
+*                 of the unshifted matrix and must be used for computation
+*                 of WGAP, the entries of WORK might stem from RRRs with
+*                 different shifts. The gaps from WBEGIN-1+OLDFST to
+*                 WBEGIN-1+OLDLST are correctly computed in DLARRB.
+*                 However, we only allow the gaps to become greater since
+*                 this is what should happen when we decrease WERR
+                  IF( OLDFST.GT.1) THEN
+                     WGAP( WBEGIN+OLDFST-2 ) =
+     $             MAX(WGAP(WBEGIN+OLDFST-2),
+     $                 W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
+     $                 - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
+                  ENDIF
+                  IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
+                     WGAP( WBEGIN+OLDLST-1 ) =
+     $               MAX(WGAP(WBEGIN+OLDLST-1),
+     $                   W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
+     $                   - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
+                  ENDIF
+*                 Each time the eigenvalues in WORK get refined, we store
+*                 the newly found approximation with all shifts applied in W
+                  DO 53 J=OLDFST,OLDLST
+                     W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
+ 53               CONTINUE
+               END IF
+
+*              Process the current node.
+               NEWFST = OLDFST
+               DO 140 J = OLDFST, OLDLST
+                  IF( J.EQ.OLDLST ) THEN
+*                    we are at the right end of the cluster, this is also the
+*                    boundary of the child cluster
+                     NEWLST = J
+                  ELSE IF ( WGAP( WBEGIN + J -1).GE.
+     $                    MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+*                    the right relative gap is big enough, the child cluster
+*                    (NEWFST,..,NEWLST) is well separated from the following
+                     NEWLST = J
+                   ELSE
+*                    inside a child cluster, the relative gap is not
+*                    big enough.
+                     GOTO 140
+                  END IF
+
+*                 Compute size of child cluster found
+                  NEWSIZ = NEWLST - NEWFST + 1
+
+*                 NEWFTT is the place in Z where the new RRR or the computed
+*                 eigenvector is to be stored
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Store representation at location of the leftmost evalue
+*                    of the cluster
+                     NEWFTT = WBEGIN + NEWFST - 1
+                  ELSE
+                     IF(WBEGIN+NEWFST-1.LT.DOL) THEN
+*                       Store representation at the left end of Z array
+                        NEWFTT = DOL - 1
+                     ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
+*                       Store representation at the right end of Z array
+                        NEWFTT = DOU
+                     ELSE
+                        NEWFTT = WBEGIN + NEWFST - 1
+                     ENDIF
+                  ENDIF
+
+                  IF( NEWSIZ.GT.1) THEN
+*
+*                    Current child is not a singleton but a cluster.
+*                    Compute and store new representation of child.
+*
+*
+*                    Compute left and right cluster gap.
+*
+*                    LGAP and RGAP are not computed from WORK because
+*                    the eigenvalue approximations may stem from RRRs
+*                    different shifts. However, W hold all eigenvalues
+*                    of the unshifted matrix. Still, the entries in WGAP
+*                    have to be computed from WORK since the entries
+*                    in W might be of the same order so that gaps are not
+*                    exhibited correctly for very close eigenvalues.
+                     IF( NEWFST.EQ.1 ) THEN
+                        LGAP = MAX( ZERO,
+     $                       W(WBEGIN)-WERR(WBEGIN) - VL )
+                    ELSE
+                        LGAP = WGAP( WBEGIN+NEWFST-2 )
+                     ENDIF
+                     RGAP = WGAP( WBEGIN+NEWLST-1 )
+*
+*                    Compute left- and rightmost eigenvalue of child
+*                    to high precision in order to shift as close
+*                    as possible and obtain as large relative gaps
+*                    as possible
+*
+                     DO 55 K =1,2
+                        IF(K.EQ.1) THEN
+                           P = INDEXW( WBEGIN-1+NEWFST )
+                        ELSE
+                           P = INDEXW( WBEGIN-1+NEWLST )
+                        ENDIF
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL DLARRB( IN, D(IBEGIN),
+     $                       WORK( INDLLD+IBEGIN-1 ),P,P,
+     $                       RQTOL, RQTOL, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       IN, IINFO )
+ 55                  CONTINUE
+*
+                     IF((WBEGIN+NEWLST-1.LT.DOL).OR.
+     $                  (WBEGIN+NEWFST-1.GT.DOU)) THEN
+*                       if the cluster contains no desired eigenvalues
+*                       skip the computation of that branch of the rep. tree
+*
+*                       We could skip before the refinement of the extremal
+*                       eigenvalues of the child, but then the representation
+*                       tree could be different from the one when nothing is
+*                       skipped. For this reason we skip at this place.
+                        IDONE = IDONE + NEWLST - NEWFST + 1
+                        GOTO 139
+                     ENDIF
+*
+*                    Compute RRR of child cluster.
+*                    Note that the new RRR is stored in Z
+*
+C                    DLARRF needs LWORK = 2*N
+                     CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
+     $                         WORK(INDLD+IBEGIN-1),
+     $                         NEWFST, NEWLST, WORK(WBEGIN),
+     $                         WGAP(WBEGIN), WERR(WBEGIN),
+     $                         SPDIAM, LGAP, RGAP, PIVMIN, TAU,
+     $                         Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
+     $                         WORK( INDWRK ), IINFO )
+                     IF( IINFO.EQ.0 ) THEN
+*                       a new RRR for the cluster was found by DLARRF
+*                       update shift and store it
+                        SSIGMA = SIGMA + TAU
+                        Z( IEND, NEWFTT+1 ) = SSIGMA
+*                       WORK() are the midpoints and WERR() the semi-width
+*                       Note that the entries in W are unchanged.
+                        DO 116 K = NEWFST, NEWLST
+                           FUDGE =
+     $                          THREE*EPS*ABS(WORK(WBEGIN+K-1))
+                           WORK( WBEGIN + K - 1 ) =
+     $                          WORK( WBEGIN + K - 1) - TAU
+                           FUDGE = FUDGE +
+     $                          FOUR*EPS*ABS(WORK(WBEGIN+K-1))
+*                          Fudge errors
+                           WERR( WBEGIN + K - 1 ) =
+     $                          WERR( WBEGIN + K - 1 ) + FUDGE
+*                          Gaps are not fudged. Provided that WERR is small
+*                          when eigenvalues are close, a zero gap indicates
+*                          that a new representation is needed for resolving
+*                          the cluster. A fudge could lead to a wrong decision
+*                          of judging eigenvalues 'separated' which in
+*                          reality are not. This could have a negative impact
+*                          on the orthogonality of the computed eigenvectors.
+ 116                    CONTINUE
+
+                        NCLUS = NCLUS + 1
+                        K = NEWCLS + 2*NCLUS
+                        IWORK( K-1 ) = NEWFST
+                        IWORK( K ) = NEWLST
+                     ELSE
+                        INFO = -2
+                        RETURN
+                     ENDIF
+                  ELSE
+*
+*                    Compute eigenvector of singleton
+*
+                     ITER = 0
+*
+                     TOL = FOUR * LOG(DBLE(IN)) * EPS
+*
+                     K = NEWFST
+                     WINDEX = WBEGIN + K - 1
+                     WINDMN = MAX(WINDEX - 1,1)
+                     WINDPL = MIN(WINDEX + 1,M)
+                     LAMBDA = WORK( WINDEX )
+                     DONE = DONE + 1
+*                    Check if eigenvector computation is to be skipped
+                     IF((WINDEX.LT.DOL).OR.
+     $                  (WINDEX.GT.DOU)) THEN
+                        ESKIP = .TRUE.
+                        GOTO 125
+                     ELSE
+                        ESKIP = .FALSE.
+                     ENDIF
+                     LEFT = WORK( WINDEX ) - WERR( WINDEX )
+                     RIGHT = WORK( WINDEX ) + WERR( WINDEX )
+                     INDEIG = INDEXW( WINDEX )
+*                    Note that since we compute the eigenpairs for a child,
+*                    all eigenvalue approximations are w.r.t the same shift.
+*                    In this case, the entries in WORK should be used for
+*                    computing the gaps since they exhibit even very small
+*                    differences in the eigenvalues, as opposed to the
+*                    entries in W which might "look" the same.
+
+                     IF( K .EQ. 1) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VL, the formula
+*                       LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
+*                       can lead to an overestimation of the left gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small left gap.
+                        LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        LGAP = WGAP(WINDMN)
+                     ENDIF
+                     IF( K .EQ. IM) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VU, the formula
+*                       can lead to an overestimation of the right gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small right gap.
+                        RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        RGAP = WGAP(WINDEX)
+                     ENDIF
+                     GAP = MIN( LGAP, RGAP )
+                     IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
+*                       The eigenvector support can become wrong
+*                       because significant entries could be cut off due to a
+*                       large GAPTOL parameter in LAR1V. Prevent this.
+                        GAPTOL = ZERO
+                     ELSE
+                        GAPTOL = GAP * EPS
+                     ENDIF
+                     ISUPMN = IN
+                     ISUPMX = 1
+*                    Update WGAP so that it holds the minimum gap
+*                    to the left or the right. This is crucial in the
+*                    case where bisection is used to ensure that the
+*                    eigenvalue is refined up to the required precision.
+*                    The correct value is restored afterwards.
+                     SAVGAP = WGAP(WINDEX)
+                     WGAP(WINDEX) = GAP
+*                    We want to use the Rayleigh Quotient Correction
+*                    as often as possible since it converges quadratically
+*                    when we are close enough to the desired eigenvalue.
+*                    However, the Rayleigh Quotient can have the wrong sign
+*                    and lead us away from the desired eigenvalue. In this
+*                    case, the best we can do is to use bisection.
+                     USEDBS = .FALSE.
+                     USEDRQ = .FALSE.
+*                    Bisection is initially turned off unless it is forced
+                     NEEDBS =  .NOT.TRYRQC
+ 120                 CONTINUE
+*                    Check if bisection should be used to refine eigenvalue
+                     IF(NEEDBS) THEN
+*                       Take the bisection as new iterate
+                        USEDBS = .TRUE.
+                        ITMP1 = IWORK( IINDR+WINDEX )
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL DLARRB( IN, D(IBEGIN),
+     $                       WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+     $                       ZERO, TWO*EPS, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       ITMP1, IINFO )
+                        IF( IINFO.NE.0 ) THEN
+                           INFO = -3
+                           RETURN
+                        ENDIF
+                        LAMBDA = WORK( WINDEX )
+*                       Reset twist index from inaccurate LAMBDA to
+*                       force computation of true MINGMA
+                        IWORK( IINDR+WINDEX ) = 0
+                     ENDIF
+*                    Given LAMBDA, compute the eigenvector.
+                     CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
+     $                    L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+     $                    WORK(INDLLD+IBEGIN-1),
+     $                    PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                    .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                    IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
+     $                    NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                     IF(ITER .EQ. 0) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ELSEIF(RESID.LT.BSTRES) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ENDIF
+                     ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
+                     ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
+                     ITER = ITER + 1
+
+*                    sin alpha <= |resid|/gap
+*                    Note that both the residual and the gap are
+*                    proportional to the matrix, so ||T|| doesn't play
+*                    a role in the quotient
+
+*
+*                    Convergence test for Rayleigh-Quotient iteration
+*                    (omitted when Bisection has been used)
+*
+                     IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
+     $                    RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
+     $                    THEN
+*                       We need to check that the RQCORR update doesn't
+*                       move the eigenvalue away from the desired one and
+*                       towards a neighbor. -> protection with bisection
+                        IF(INDEIG.LE.NEGCNT) THEN
+*                          The wanted eigenvalue lies to the left
+                           SGNDEF = -ONE
+                        ELSE
+*                          The wanted eigenvalue lies to the right
+                           SGNDEF = ONE
+                        ENDIF
+*                       We only use the RQCORR if it improves the
+*                       the iterate reasonably.
+                        IF( ( RQCORR*SGNDEF.GE.ZERO )
+     $                       .AND.( LAMBDA + RQCORR.LE. RIGHT)
+     $                       .AND.( LAMBDA + RQCORR.GE. LEFT)
+     $                       ) THEN
+                           USEDRQ = .TRUE.
+*                          Store new midpoint of bisection interval in WORK
+                           IF(SGNDEF.EQ.ONE) THEN
+*                             The current LAMBDA is on the left of the true
+*                             eigenvalue
+                              LEFT = LAMBDA
+*                             We prefer to assume that the error estimate
+*                             is correct. We could make the interval not
+*                             as a bracket but to be modified if the RQCORR
+*                             chooses to. In this case, the RIGHT side should
+*                             be modified as follows:
+*                              RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
+                           ELSE
+*                             The current LAMBDA is on the right of the true
+*                             eigenvalue
+                              RIGHT = LAMBDA
+*                             See comment about assuming the error estimate is
+*                             correct above.
+*                              LEFT = MIN(LEFT, LAMBDA + RQCORR)
+                           ENDIF
+                           WORK( WINDEX ) =
+     $                       HALF * (RIGHT + LEFT)
+*                          Take RQCORR since it has the correct sign and
+*                          improves the iterate reasonably
+                           LAMBDA = LAMBDA + RQCORR
+*                          Update width of error interval
+                           WERR( WINDEX ) =
+     $                             HALF * (RIGHT-LEFT)
+                        ELSE
+                           NEEDBS = .TRUE.
+                        ENDIF
+                        IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
+*                             The eigenvalue is computed to bisection accuracy
+*                             compute eigenvector and stop
+                           USEDBS = .TRUE.
+                           GOTO 120
+                        ELSEIF( ITER.LT.MAXITR ) THEN
+                           GOTO 120
+                        ELSEIF( ITER.EQ.MAXITR ) THEN
+                           NEEDBS = .TRUE.
+                           GOTO 120
+                        ELSE
+                           INFO = 5
+                           RETURN
+                        END IF
+                     ELSE
+                        STP2II = .FALSE.
+        IF(USEDRQ .AND. USEDBS .AND.
+     $                     BSTRES.LE.RESID) THEN
+                           LAMBDA = BSTW
+                           STP2II = .TRUE.
+                        ENDIF
+                        IF (STP2II) THEN
+*                          improve error angle by second step
+                           CALL DLAR1V( IN, 1, IN, LAMBDA,
+     $                          D( IBEGIN ), L( IBEGIN ),
+     $                          WORK(INDLD+IBEGIN-1),
+     $                          WORK(INDLLD+IBEGIN-1),
+     $                          PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                          .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                          IWORK( IINDR+WINDEX ),
+     $                          ISUPPZ( 2*WINDEX-1 ),
+     $                          NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                        ENDIF
+                        WORK( WINDEX ) = LAMBDA
+                     END IF
+*
+*                    Compute FP-vector support w.r.t. whole matrix
+*
+                     ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
+                     ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
+                     ZFROM = ISUPPZ( 2*WINDEX-1 )
+                     ZTO = ISUPPZ( 2*WINDEX )
+                     ISUPMN = ISUPMN + OLDIEN
+                     ISUPMX = ISUPMX + OLDIEN
+*                    Ensure vector is ok if support in the RQI has changed
+                     IF(ISUPMN.LT.ZFROM) THEN
+                        DO 122 II = ISUPMN,ZFROM-1
+                           Z( II, WINDEX ) = ZERO
+ 122                    CONTINUE
+                     ENDIF
+                     IF(ISUPMX.GT.ZTO) THEN
+                        DO 123 II = ZTO+1,ISUPMX
+                           Z( II, WINDEX ) = ZERO
+ 123                    CONTINUE
+                     ENDIF
+                     CALL DSCAL( ZTO-ZFROM+1, NRMINV,
+     $                       Z( ZFROM, WINDEX ), 1 )
+ 125                 CONTINUE
+*                    Update W
+                     W( WINDEX ) = LAMBDA+SIGMA
+*                    Recompute the gaps on the left and right
+*                    But only allow them to become larger and not
+*                    smaller (which can only happen through "bad"
+*                    cancellation and doesn't reflect the theory
+*                    where the initial gaps are underestimated due
+*                    to WERR being too crude.)
+                     IF(.NOT.ESKIP) THEN
+                        IF( K.GT.1) THEN
+                           WGAP( WINDMN ) = MAX( WGAP(WINDMN),
+     $                          W(WINDEX)-WERR(WINDEX)
+     $                          - W(WINDMN)-WERR(WINDMN) )
+                        ENDIF
+                        IF( WINDEX.LT.WEND ) THEN
+                           WGAP( WINDEX ) = MAX( SAVGAP,
+     $                          W( WINDPL )-WERR( WINDPL )
+     $                          - W( WINDEX )-WERR( WINDEX) )
+                        ENDIF
+                     ENDIF
+                     IDONE = IDONE + 1
+                  ENDIF
+*                 here ends the code for the current child
+*
+ 139              CONTINUE
+*                 Proceed to any remaining child nodes
+                  NEWFST = J + 1
+ 140           CONTINUE
+ 150        CONTINUE
+            NDEPTH = NDEPTH + 1
+            GO TO 40
+         END IF
+         IBEGIN = IEND + 1
+         WBEGIN = WEND + 1
+ 170  CONTINUE
+*
+
+      RETURN
+*
+*     End of DLARRV
+*
+      END
diff --git a/SRC/dlartg.f b/SRC/dlartg.f
new file mode 100644
index 00000000..eb807c1d
--- /dev/null
+++ b/SRC/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/dlartv.f b/SRC/dlartv.f
new file mode 100644
index 00000000..8e13cc70
--- /dev/null
+++ b/SRC/dlartv.f
@@ -0,0 +1,76 @@
+      SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), S( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARTV applies a vector of real plane rotations to elements of the
+*  real vectors x and y. For i = 1,2,...,n
+*
+*     ( x(i) ) := (  c(i)  s(i) ) ( x(i) )
+*     ( y(i) )    ( -s(i)  c(i) ) ( y(i) )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector x.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) DOUBLE PRECISION array,
+*                         dimension (1+(N-1)*INCY)
+*          The vector y.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX, IY
+      DOUBLE PRECISION   XI, YI
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = X( IX )
+         YI = Y( IY )
+         X( IX ) = C( IC )*XI + S( IC )*YI
+         Y( IY ) = C( IC )*YI - S( IC )*XI
+         IX = IX + INCX
+         IY = IY + INCY
+         IC = IC + INCC
+   10 CONTINUE
+      RETURN
+*
+*     End of DLARTV
+*
+      END
diff --git a/SRC/dlaruv.f b/SRC/dlaruv.f
new file mode 100644
index 00000000..687c2c45
--- /dev/null
+++ b/SRC/dlaruv.f
@@ -0,0 +1,386 @@
+      SUBROUTINE DLARUV( ISEED, N, X )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISEED( 4 )
+      DOUBLE PRECISION   X( N )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARUV returns a vector of n random real numbers from a uniform (0,1)
+*  distribution (n <= 128).
+*
+*  This is an auxiliary routine called by DLARNV and ZLARNV.
+*
+*  Arguments
+*  =========
+*
+*  ISEED   (input/output) INTEGER array, dimension (4)
+*          On entry, the seed of the random number generator; the array
+*          elements must be between 0 and 4095, and ISEED(4) must be
+*          odd.
+*          On exit, the seed is updated.
+*
+*  N       (input) INTEGER
+*          The number of random numbers to be generated. N <= 128.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (N)
+*          The generated random numbers.
+*
+*  Further Details
+*  ===============
+*
+*  This routine uses a multiplicative congruential method with modulus
+*  2**48 and multiplier 33952834046453 (see G.S.Fishman,
+*  'Multiplicative congruential random number generators with modulus
+*  2**b: an exhaustive analysis for b = 32 and a partial analysis for
+*  b = 48', Math. Comp. 189, pp 331-344, 1990).
+*
+*  48-bit integers are stored in 4 integer array elements with 12 bits
+*  per element. Hence the routine is portable across machines with
+*  integers of 32 bits or more.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      INTEGER            LV, IPW2
+      DOUBLE PRECISION   R
+      PARAMETER          ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
+*     ..
+*     .. Local Arrays ..
+      INTEGER            MM( LV, 4 )
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MIN, MOD
+*     ..
+*     .. Data statements ..
+      DATA               ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
+     $                   2549 /
+      DATA               ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
+     $                   1145 /
+      DATA               ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
+     $                   2253 /
+      DATA               ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
+     $                   305 /
+      DATA               ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
+     $                   3301 /
+      DATA               ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
+     $                   1065 /
+      DATA               ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
+     $                   3133 /
+      DATA               ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
+     $                   2913 /
+      DATA               ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
+     $                   3285 /
+      DATA               ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
+     $                   1241 /
+      DATA               ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
+     $                   1197 /
+      DATA               ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
+     $                   3729 /
+      DATA               ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
+     $                   2501 /
+      DATA               ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
+     $                   1673 /
+      DATA               ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
+     $                   541 /
+      DATA               ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
+     $                   2753 /
+      DATA               ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
+     $                   949 /
+      DATA               ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
+     $                   2361 /
+      DATA               ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
+     $                   1165 /
+      DATA               ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
+     $                   4081 /
+      DATA               ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
+     $                   2725 /
+      DATA               ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
+     $                   3305 /
+      DATA               ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
+     $                   3069 /
+      DATA               ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
+     $                   3617 /
+      DATA               ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
+     $                   3733 /
+      DATA               ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
+     $                   409 /
+      DATA               ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
+     $                   2157 /
+      DATA               ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
+     $                   1361 /
+      DATA               ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
+     $                   3973 /
+      DATA               ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
+     $                   1865 /
+      DATA               ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
+     $                   2525 /
+      DATA               ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
+     $                   1409 /
+      DATA               ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
+     $                   3445 /
+      DATA               ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
+     $                   3577 /
+      DATA               ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
+     $                   77 /
+      DATA               ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
+     $                   3761 /
+      DATA               ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
+     $                   2149 /
+      DATA               ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
+     $                   1449 /
+      DATA               ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
+     $                   3005 /
+      DATA               ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
+     $                   225 /
+      DATA               ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
+     $                   85 /
+      DATA               ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
+     $                   3673 /
+      DATA               ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
+     $                   3117 /
+      DATA               ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
+     $                   3089 /
+      DATA               ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
+     $                   1349 /
+      DATA               ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
+     $                   2057 /
+      DATA               ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
+     $                   413 /
+      DATA               ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
+     $                   65 /
+      DATA               ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
+     $                   1845 /
+      DATA               ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
+     $                   697 /
+      DATA               ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
+     $                   3085 /
+      DATA               ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
+     $                   3441 /
+      DATA               ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
+     $                   1573 /
+      DATA               ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
+     $                   3689 /
+      DATA               ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
+     $                   2941 /
+      DATA               ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
+     $                   929 /
+      DATA               ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
+     $                   533 /
+      DATA               ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
+     $                   2841 /
+      DATA               ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
+     $                   4077 /
+      DATA               ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
+     $                   721 /
+      DATA               ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
+     $                   2821 /
+      DATA               ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
+     $                   2249 /
+      DATA               ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
+     $                   2397 /
+      DATA               ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
+     $                   2817 /
+      DATA               ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
+     $                   245 /
+      DATA               ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
+     $                   1913 /
+      DATA               ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
+     $                   1997 /
+      DATA               ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
+     $                   3121 /
+      DATA               ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
+     $                   997 /
+      DATA               ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
+     $                   1833 /
+      DATA               ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
+     $                   2877 /
+      DATA               ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
+     $                   1633 /
+      DATA               ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
+     $                   981 /
+      DATA               ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
+     $                   2009 /
+      DATA               ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
+     $                   941 /
+      DATA               ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
+     $                   2449 /
+      DATA               ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
+     $                   197 /
+      DATA               ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
+     $                   2441 /
+      DATA               ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
+     $                   285 /
+      DATA               ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
+     $                   1473 /
+      DATA               ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
+     $                   2741 /
+      DATA               ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
+     $                   3129 /
+      DATA               ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
+     $                   909 /
+      DATA               ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
+     $                   2801 /
+      DATA               ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
+     $                   421 /
+      DATA               ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
+     $                   4073 /
+      DATA               ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
+     $                   2813 /
+      DATA               ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
+     $                   2337 /
+      DATA               ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
+     $                   1429 /
+      DATA               ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
+     $                   1177 /
+      DATA               ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
+     $                   1901 /
+      DATA               ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
+     $                   81 /
+      DATA               ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
+     $                   1669 /
+      DATA               ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
+     $                   2633 /
+      DATA               ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
+     $                   2269 /
+      DATA               ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
+     $                   129 /
+      DATA               ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
+     $                   1141 /
+      DATA               ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
+     $                   249 /
+      DATA               ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
+     $                   3917 /
+      DATA               ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
+     $                   2481 /
+      DATA               ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
+     $                   3941 /
+      DATA               ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
+     $                   2217 /
+      DATA               ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
+     $                   2749 /
+      DATA               ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
+     $                   3041 /
+      DATA               ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
+     $                   1877 /
+      DATA               ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
+     $                   345 /
+      DATA               ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
+     $                   2861 /
+      DATA               ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
+     $                   1809 /
+      DATA               ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
+     $                   3141 /
+      DATA               ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
+     $                   2825 /
+      DATA               ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
+     $                   157 /
+      DATA               ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
+     $                   2881 /
+      DATA               ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
+     $                   3637 /
+      DATA               ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
+     $                   1465 /
+      DATA               ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
+     $                   2829 /
+      DATA               ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
+     $                   2161 /
+      DATA               ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
+     $                   3365 /
+      DATA               ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
+     $                   361 /
+      DATA               ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
+     $                   2685 /
+      DATA               ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
+     $                   3745 /
+      DATA               ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
+     $                   2325 /
+      DATA               ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
+     $                   3609 /
+      DATA               ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
+     $                   3821 /
+      DATA               ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
+     $                   3537 /
+      DATA               ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
+     $                   517 /
+      DATA               ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
+     $                   3017 /
+      DATA               ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
+     $                   2141 /
+      DATA               ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
+     $                   1537 /
+*     ..
+*     .. Executable Statements ..
+*
+      I1 = ISEED( 1 )
+      I2 = ISEED( 2 )
+      I3 = ISEED( 3 )
+      I4 = ISEED( 4 )
+*
+      DO 10 I = 1, MIN( N, LV )
+*	  
+  20     CONTINUE
+*
+*        Multiply the seed by i-th power of the multiplier modulo 2**48
+*
+         IT4 = I4*MM( I, 4 )
+         IT3 = IT4 / IPW2
+         IT4 = IT4 - IPW2*IT3
+         IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
+         IT2 = IT3 / IPW2
+         IT3 = IT3 - IPW2*IT2
+         IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
+         IT1 = IT2 / IPW2
+         IT2 = IT2 - IPW2*IT1
+         IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
+     $         I4*MM( I, 1 )
+         IT1 = MOD( IT1, IPW2 )
+*
+*        Convert 48-bit integer to a real number in the interval (0,1)
+*
+         X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
+     $            DBLE( IT4 ) ) ) )
+*
+         IF (X( I ).EQ.1.0D0) THEN
+*           If a real number has n bits of precision, and the first
+*           n bits of the 48-bit integer above happen to be all 1 (which
+*           will occur about once every 2**n calls), then X( I ) will
+*           be rounded to exactly 1.0. 
+*           Since X( I ) is not supposed to return exactly 0.0 or 1.0,
+*           the statistically correct thing to do in this situation is
+*           simply to iterate again.
+*           N.B. the case X( I ) = 0.0 should not be possible.	
+            I1 = I1 + 2
+            I2 = I2 + 2
+            I3 = I3 + 2
+            I4 = I4 + 2
+            GOTO 20
+         END IF
+*
+   10 CONTINUE
+*
+*     Return final value of seed
+*
+      ISEED( 1 ) = IT1
+      ISEED( 2 ) = IT2
+      ISEED( 3 ) = IT3
+      ISEED( 4 ) = IT4
+      RETURN
+*
+*     End of DLARUV
+*
+      END
diff --git a/SRC/dlarz.f b/SRC/dlarz.f
new file mode 100644
index 00000000..b302fdc2
--- /dev/null
+++ b/SRC/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/dlarzb.f b/SRC/dlarzb.f
new file mode 100644
index 00000000..ec59d8d5
--- /dev/null
+++ b/SRC/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/dlarzt.f b/SRC/dlarzt.f
new file mode 100644
index 00000000..d79636e0
--- /dev/null
+++ b/SRC/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/dlas2.f b/SRC/dlas2.f
new file mode 100644
index 00000000..e100a4d8
--- /dev/null
+++ b/SRC/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/dlascl.f b/SRC/dlascl.f
new file mode 100644
index 00000000..efc0685e
--- /dev/null
+++ b/SRC/dlascl.f
@@ -0,0 +1,283 @@
+      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, DISNAN
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH, DISNAN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
+         INFO = -4
+      ELSE IF( DISNAN(CTO) ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      IF( CFROM1.EQ.CFROMC ) THEN
+!        CFROMC is an inf.  Multiply by a correctly signed zero for
+!        finite CTOC, or a NaN if CTOC is infinite.
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+         CTO1 = CTOC
+      ELSE
+         CTO1 = CTOC / BIGNUM
+         IF( CTO1.EQ.CTOC ) THEN
+!           CTOC is either 0 or an inf.  In both cases, CTOC itself
+!           serves as the correct multiplication factor.
+            MUL = CTOC
+            DONE = .TRUE.
+            CFROMC = ONE
+         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+            MUL = SMLNUM
+            DONE = .FALSE.
+            CFROMC = CFROM1
+         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+            MUL = BIGNUM
+            DONE = .FALSE.
+            CTOC = CTO1
+         ELSE
+            MUL = CTOC / CFROMC
+            DONE = .TRUE.
+         END IF
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of DLASCL
+*
+      END
diff --git a/SRC/dlasd0.f b/SRC/dlasd0.f
new file mode 100644
index 00000000..0fb5ccc8
--- /dev/null
+++ b/SRC/dlasd0.f
@@ -0,0 +1,230 @@
+      SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
+     $                   WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDU, LDVT, N, SMLSIZ, SQRE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Using a divide and conquer approach, DLASD0 computes the singular
+*  value decomposition (SVD) of a real upper bidiagonal N-by-M
+*  matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
+*  The algorithm computes orthogonal matrices U and VT such that
+*  B = U * S * VT. The singular values S are overwritten on D.
+*
+*  A related subroutine, DLASDA, computes only the singular values,
+*  and optionally, the singular vectors in compact form.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         On entry, the row dimension of the upper bidiagonal matrix.
+*         This is also the dimension of the main diagonal array D.
+*
+*  SQRE   (input) INTEGER
+*         Specifies the column dimension of the bidiagonal matrix.
+*         = 0: The bidiagonal matrix has column dimension M = N;
+*         = 1: The bidiagonal matrix has column dimension M = N+1;
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix.
+*         On exit D, if INFO = 0, contains its singular values.
+*
+*  E      (input) DOUBLE PRECISION array, dimension (M-1)
+*         Contains the subdiagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  U      (output) DOUBLE PRECISION array, dimension at least (LDQ, N)
+*         On exit, U contains the left singular vectors.
+*
+*  LDU    (input) INTEGER
+*         On entry, leading dimension of U.
+*
+*  VT     (output) DOUBLE PRECISION array, dimension at least (LDVT, M)
+*         On exit, VT' contains the right singular vectors.
+*
+*  LDVT   (input) INTEGER
+*         On entry, leading dimension of VT.
+*
+*  SMLSIZ (input) INTEGER
+*         On entry, maximum size of the subproblems at the
+*         bottom of the computation tree.
+*
+*  IWORK  (workspace) INTEGER work array.
+*         Dimension must be at least (8 * N)
+*
+*  WORK   (workspace) DOUBLE PRECISION work array.
+*         Dimension must be at least (3 * M**2 + 2 * M)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
+     $                   J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
+     $                   NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASD1, DLASDQ, DLASDT, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -2
+      END IF
+*
+      M = N + SQRE
+*
+      IF( LDU.LT.N ) THEN
+         INFO = -6
+      ELSE IF( LDVT.LT.M ) THEN
+         INFO = -8
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD0', -INFO )
+         RETURN
+      END IF
+*
+*     If the input matrix is too small, call DLASDQ to find the SVD.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
+     $                LDU, WORK, INFO )
+         RETURN
+      END IF
+*
+*     Set up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+      IDXQ = NDIMR + N
+      IWK = IDXQ + N
+      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     For the nodes on bottom level of the tree, solve
+*     their subproblems by DLASDQ.
+*
+      NDB1 = ( ND+1 ) / 2
+      NCC = 0
+      DO 30 I = NDB1, ND
+*
+*     IC : center row of each node
+*     NL : number of rows of left  subproblem
+*     NR : number of rows of right subproblem
+*     NLF: starting row of the left   subproblem
+*     NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NLP1 = NL + 1
+         NR = IWORK( NDIMR+I1 )
+         NRP1 = NR + 1
+         NLF = IC - NL
+         NRF = IC + 1
+         SQREI = 1
+         CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
+     $                VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
+     $                U( NLF, NLF ), LDU, WORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         ITEMP = IDXQ + NLF - 2
+         DO 10 J = 1, NL
+            IWORK( ITEMP+J ) = J
+   10    CONTINUE
+         IF( I.EQ.ND ) THEN
+            SQREI = SQRE
+         ELSE
+            SQREI = 1
+         END IF
+         NRP1 = NR + SQREI
+         CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
+     $                VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
+     $                U( NRF, NRF ), LDU, WORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         ITEMP = IDXQ + IC
+         DO 20 J = 1, NR
+            IWORK( ITEMP+J-1 ) = J
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Now conquer each subproblem bottom-up.
+*
+      DO 50 LVL = NLVL, 1, -1
+*
+*        Find the first node LF and last node LL on the
+*        current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 40 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
+               SQREI = SQRE
+            ELSE
+               SQREI = 1
+            END IF
+            IDXQC = IDXQ + NLF - 1
+            ALPHA = D( IC )
+            BETA = E( IC )
+            CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
+     $                   U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
+     $                   IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+   40    CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of DLASD0
+*
+      END
diff --git a/SRC/dlasd1.f b/SRC/dlasd1.f
new file mode 100644
index 00000000..8b80ba1d
--- /dev/null
+++ b/SRC/dlasd1.f
@@ -0,0 +1,232 @@
+      SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
+     $                   IDXQ, IWORK, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDU, LDVT, NL, NR, SQRE
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IDXQ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
+*  where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
+*
+*  A related subroutine DLASD7 handles the case in which the singular
+*  values (and the singular vectors in factored form) are desired.
+*
+*  DLASD1 computes the SVD as follows:
+*
+*                ( D1(in)  0    0     0 )
+*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
+*                (   0     0   D2(in) 0 )
+*
+*      = U(out) * ( D(out) 0) * VT(out)
+*
+*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+*  elsewhere; and the entry b is empty if SQRE = 0.
+*
+*  The left singular vectors of the original matrix are stored in U, and
+*  the transpose of the right singular vectors are stored in VT, and the
+*  singular values are in D.  The algorithm consists of three stages:
+*
+*     The first stage consists of deflating the size of the problem
+*     when there are multiple singular values or when there are zeros in
+*     the Z vector.  For each such occurence the dimension of the
+*     secular equation problem is reduced by one.  This stage is
+*     performed by the routine DLASD2.
+*
+*     The second stage consists of calculating the updated
+*     singular values. This is done by finding the square roots of the
+*     roots of the secular equation via the routine DLASD4 (as called
+*     by DLASD3). This routine also calculates the singular vectors of
+*     the current problem.
+*
+*     The final stage consists of computing the updated singular vectors
+*     directly using the updated singular values.  The singular vectors
+*     for the current problem are multiplied with the singular vectors
+*     from the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  D      (input/output) DOUBLE PRECISION array,
+*                        dimension (N = NL+NR+1).
+*         On entry D(1:NL,1:NL) contains the singular values of the
+*         upper block; and D(NL+2:N) contains the singular values of
+*         the lower block. On exit D(1:N) contains the singular values
+*         of the modified matrix.
+*
+*  ALPHA  (input/output) DOUBLE PRECISION
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input/output) DOUBLE PRECISION
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)
+*         On entry U(1:NL, 1:NL) contains the left singular vectors of
+*         the upper block; U(NL+2:N, NL+2:N) contains the left singular
+*         vectors of the lower block. On exit U contains the left
+*         singular vectors of the bidiagonal matrix.
+*
+*  LDU    (input) INTEGER
+*         The leading dimension of the array U.  LDU >= max( 1, N ).
+*
+*  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
+*         where M = N + SQRE.
+*         On entry VT(1:NL+1, 1:NL+1)' contains the right singular
+*         vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
+*         the right singular vectors of the lower block. On exit
+*         VT' contains the right singular vectors of the
+*         bidiagonal matrix.
+*
+*  LDVT   (input) INTEGER
+*         The leading dimension of the array VT.  LDVT >= max( 1, M ).
+*
+*  IDXQ  (output) INTEGER array, dimension(N)
+*         This contains the permutation which will reintegrate the
+*         subproblem just solved back into sorted order, i.e.
+*         D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  IWORK  (workspace) INTEGER array, dimension( 4 * N )
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+*
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
+     $                   IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
+      DOUBLE PRECISION   ORGNRM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( NL.LT.1 ) THEN
+         INFO = -1
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD1', -INFO )
+         RETURN
+      END IF
+*
+      N = NL + NR + 1
+      M = N + SQRE
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in DLASD2 and DLASD3.
+*
+      LDU2 = N
+      LDVT2 = M
+*
+      IZ = 1
+      ISIGMA = IZ + M
+      IU2 = ISIGMA + N
+      IVT2 = IU2 + LDU2*N
+      IQ = IVT2 + LDVT2*M
+*
+      IDX = 1
+      IDXC = IDX + N
+      COLTYP = IDXC + N
+      IDXP = COLTYP + N
+*
+*     Scale.
+*
+      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+      D( NL+1 ) = ZERO
+      DO 10 I = 1, N
+         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+            ORGNRM = ABS( D( I ) )
+         END IF
+   10 CONTINUE
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      ALPHA = ALPHA / ORGNRM
+      BETA = BETA / ORGNRM
+*
+*     Deflate singular values.
+*
+      CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
+     $             VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
+     $             WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
+     $             IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
+*
+*     Solve Secular Equation and update singular vectors.
+*
+      LDQ = K
+      CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
+     $             U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
+     $             LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
+     $             INFO )
+      IF( INFO.NE.0 ) THEN
+         RETURN
+      END IF
+*
+*     Unscale.
+*
+      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+*     Prepare the IDXQ sorting permutation.
+*
+      N1 = K
+      N2 = N - K
+      CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+      RETURN
+*
+*     End of DLASD1
+*
+      END
diff --git a/SRC/dlasd2.f b/SRC/dlasd2.f
new file mode 100644
index 00000000..f382de18
--- /dev/null
+++ b/SRC/dlasd2.f
@@ -0,0 +1,512 @@
+      SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
+     $                   LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
+     $                   IDXC, IDXQ, COLTYP, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      INTEGER            COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
+     $                   IDXQ( * )
+      DOUBLE PRECISION   D( * ), DSIGMA( * ), U( LDU, * ),
+     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+     $                   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASD2 merges the two sets of singular values together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  singular values are close together or if there is a tiny entry in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  DLASD2 is called from DLASD1.
+*
+*  Arguments
+*  =========
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has N = NL + NR + 1 rows and
+*         M = N + SQRE >= N columns.
+*
+*  K      (output) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension(N)
+*         On entry D contains the singular values of the two submatrices
+*         to be combined.  On exit D contains the trailing (N-K) updated
+*         singular values (those which were deflated) sorted into
+*         increasing order.
+*
+*  Z      (output) DOUBLE PRECISION array, dimension(N)
+*         On exit Z contains the updating row vector in the secular
+*         equation.
+*
+*  ALPHA  (input) DOUBLE PRECISION
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input) DOUBLE PRECISION
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)
+*         On entry U contains the left singular vectors of two
+*         submatrices in the two square blocks with corners at (1,1),
+*         (NL, NL), and (NL+2, NL+2), (N,N).
+*         On exit U contains the trailing (N-K) updated left singular
+*         vectors (those which were deflated) in its last N-K columns.
+*
+*  LDU    (input) INTEGER
+*         The leading dimension of the array U.  LDU >= N.
+*
+*  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
+*         On entry VT' contains the right singular vectors of two
+*         submatrices in the two square blocks with corners at (1,1),
+*         (NL+1, NL+1), and (NL+2, NL+2), (M,M).
+*         On exit VT' contains the trailing (N-K) updated right singular
+*         vectors (those which were deflated) in its last N-K columns.
+*         In case SQRE =1, the last row of VT spans the right null
+*         space.
+*
+*  LDVT   (input) INTEGER
+*         The leading dimension of the array VT.  LDVT >= M.
+*
+*  DSIGMA (output) DOUBLE PRECISION array, dimension (N)
+*         Contains a copy of the diagonal elements (K-1 singular values
+*         and one zero) in the secular equation.
+*
+*  U2     (output) DOUBLE PRECISION array, dimension(LDU2,N)
+*         Contains a copy of the first K-1 left singular vectors which
+*         will be used by DLASD3 in a matrix multiply (DGEMM) to solve
+*         for the new left singular vectors. U2 is arranged into four
+*         blocks. The first block contains a column with 1 at NL+1 and
+*         zero everywhere else; the second block contains non-zero
+*         entries only at and above NL; the third contains non-zero
+*         entries only below NL+1; and the fourth is dense.
+*
+*  LDU2   (input) INTEGER
+*         The leading dimension of the array U2.  LDU2 >= N.
+*
+*  VT2    (output) DOUBLE PRECISION array, dimension(LDVT2,N)
+*         VT2' contains a copy of the first K right singular vectors
+*         which will be used by DLASD3 in a matrix multiply (DGEMM) to
+*         solve for the new right singular vectors. VT2 is arranged into
+*         three blocks. The first block contains a row that corresponds
+*         to the special 0 diagonal element in SIGMA; the second block
+*         contains non-zeros only at and before NL +1; the third block
+*         contains non-zeros only at and after  NL +2.
+*
+*  LDVT2  (input) INTEGER
+*         The leading dimension of the array VT2.  LDVT2 >= M.
+*
+*  IDXP   (workspace) INTEGER array dimension(N)
+*         This will contain the permutation used to place deflated
+*         values of D at the end of the array. On output IDXP(2:K)
+*         points to the nondeflated D-values and IDXP(K+1:N)
+*         points to the deflated singular values.
+*
+*  IDX    (workspace) INTEGER array dimension(N)
+*         This will contain the permutation used to sort the contents of
+*         D into ascending order.
+*
+*  IDXC   (output) INTEGER array dimension(N)
+*         This will contain the permutation used to arrange the columns
+*         of the deflated U matrix into three groups:  the first group
+*         contains non-zero entries only at and above NL, the second
+*         contains non-zero entries only below NL+2, and the third is
+*         dense.
+*
+*  IDXQ   (input/output) INTEGER array dimension(N)
+*         This contains the permutation which separately sorts the two
+*         sub-problems in D into ascending order.  Note that entries in
+*         the first hlaf of this permutation must first be moved one
+*         position backward; and entries in the second half
+*         must first have NL+1 added to their values.
+*
+*  COLTYP (workspace/output) INTEGER array dimension(N)
+*         As workspace, this will contain a label which will indicate
+*         which of the following types a column in the U2 matrix or a
+*         row in the VT2 matrix is:
+*         1 : non-zero in the upper half only
+*         2 : non-zero in the lower half only
+*         3 : dense
+*         4 : deflated
+*
+*         On exit, it is an array of dimension 4, with COLTYP(I) being
+*         the dimension of the I-th type columns.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+     $                   EIGHT = 8.0D+0 )
+*     ..
+*     .. Local Arrays ..
+      INTEGER            CTOT( 4 ), PSM( 4 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
+     $                   N, NLP1, NLP2
+      DOUBLE PRECISION   C, EPS, HLFTOL, S, TAU, TOL, Z1
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           DLAMCH, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( NL.LT.1 ) THEN
+         INFO = -1
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+         INFO = -3
+      END IF
+*
+      N = NL + NR + 1
+      M = N + SQRE
+*
+      IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDVT.LT.M ) THEN
+         INFO = -12
+      ELSE IF( LDU2.LT.N ) THEN
+         INFO = -15
+      ELSE IF( LDVT2.LT.M ) THEN
+         INFO = -17
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD2', -INFO )
+         RETURN
+      END IF
+*
+      NLP1 = NL + 1
+      NLP2 = NL + 2
+*
+*     Generate the first part of the vector Z; and move the singular
+*     values in the first part of D one position backward.
+*
+      Z1 = ALPHA*VT( NLP1, NLP1 )
+      Z( 1 ) = Z1
+      DO 10 I = NL, 1, -1
+         Z( I+1 ) = ALPHA*VT( I, NLP1 )
+         D( I+1 ) = D( I )
+         IDXQ( I+1 ) = IDXQ( I ) + 1
+   10 CONTINUE
+*
+*     Generate the second part of the vector Z.
+*
+      DO 20 I = NLP2, M
+         Z( I ) = BETA*VT( I, NLP2 )
+   20 CONTINUE
+*
+*     Initialize some reference arrays.
+*
+      DO 30 I = 2, NLP1
+         COLTYP( I ) = 1
+   30 CONTINUE
+      DO 40 I = NLP2, N
+         COLTYP( I ) = 2
+   40 CONTINUE
+*
+*     Sort the singular values into increasing order
+*
+      DO 50 I = NLP2, N
+         IDXQ( I ) = IDXQ( I ) + NLP1
+   50 CONTINUE
+*
+*     DSIGMA, IDXC, IDXC, and the first column of U2
+*     are used as storage space.
+*
+      DO 60 I = 2, N
+         DSIGMA( I ) = D( IDXQ( I ) )
+         U2( I, 1 ) = Z( IDXQ( I ) )
+         IDXC( I ) = COLTYP( IDXQ( I ) )
+   60 CONTINUE
+*
+      CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+      DO 70 I = 2, N
+         IDXI = 1 + IDX( I )
+         D( I ) = DSIGMA( IDXI )
+         Z( I ) = U2( IDXI, 1 )
+         COLTYP( I ) = IDXC( IDXI )
+   70 CONTINUE
+*
+*     Calculate the allowable deflation tolerance
+*
+      EPS = DLAMCH( 'Epsilon' )
+      TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+      TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+*     There are 2 kinds of deflation -- first a value in the z-vector
+*     is small, second two (or more) singular values are very close
+*     together (their difference is small).
+*
+*     If the value in the z-vector is small, we simply permute the
+*     array so that the corresponding singular value is moved to the
+*     end.
+*
+*     If two values in the D-vector are close, we perform a two-sided
+*     rotation designed to make one of the corresponding z-vector
+*     entries zero, and then permute the array so that the deflated
+*     singular value is moved to the end.
+*
+*     If there are multiple singular values then the problem deflates.
+*     Here the number of equal singular values are found.  As each equal
+*     singular value is found, an elementary reflector is computed to
+*     rotate the corresponding singular subspace so that the
+*     corresponding components of Z are zero in this new basis.
+*
+      K = 1
+      K2 = N + 1
+      DO 80 J = 2, N
+         IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            IDXP( K2 ) = J
+            COLTYP( J ) = 4
+            IF( J.EQ.N )
+     $         GO TO 120
+         ELSE
+            JPREV = J
+            GO TO 90
+         END IF
+   80 CONTINUE
+   90 CONTINUE
+      J = JPREV
+  100 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 110
+      IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         IDXP( K2 ) = J
+         COLTYP( J ) = 4
+      ELSE
+*
+*        Check if singular values are close enough to allow deflation.
+*
+         IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            S = Z( JPREV )
+            C = Z( J )
+*
+*           Find sqrt(a**2+b**2) without overflow or
+*           destructive underflow.
+*
+            TAU = DLAPY2( C, S )
+            C = C / TAU
+            S = -S / TAU
+            Z( J ) = TAU
+            Z( JPREV ) = ZERO
+*
+*           Apply back the Givens rotation to the left and right
+*           singular vector matrices.
+*
+            IDXJP = IDXQ( IDX( JPREV )+1 )
+            IDXJ = IDXQ( IDX( J )+1 )
+            IF( IDXJP.LE.NLP1 ) THEN
+               IDXJP = IDXJP - 1
+            END IF
+            IF( IDXJ.LE.NLP1 ) THEN
+               IDXJ = IDXJ - 1
+            END IF
+            CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
+            CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
+     $                 S )
+            IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
+               COLTYP( J ) = 3
+            END IF
+            COLTYP( JPREV ) = 4
+            K2 = K2 - 1
+            IDXP( K2 ) = JPREV
+            JPREV = J
+         ELSE
+            K = K + 1
+            U2( K, 1 ) = Z( JPREV )
+            DSIGMA( K ) = D( JPREV )
+            IDXP( K ) = JPREV
+            JPREV = J
+         END IF
+      END IF
+      GO TO 100
+  110 CONTINUE
+*
+*     Record the last singular value.
+*
+      K = K + 1
+      U2( K, 1 ) = Z( JPREV )
+      DSIGMA( K ) = D( JPREV )
+      IDXP( K ) = JPREV
+*
+  120 CONTINUE
+*
+*     Count up the total number of the various types of columns, then
+*     form a permutation which positions the four column types into
+*     four groups of uniform structure (although one or more of these
+*     groups may be empty).
+*
+      DO 130 J = 1, 4
+         CTOT( J ) = 0
+  130 CONTINUE
+      DO 140 J = 2, N
+         CT = COLTYP( J )
+         CTOT( CT ) = CTOT( CT ) + 1
+  140 CONTINUE
+*
+*     PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+      PSM( 1 ) = 2
+      PSM( 2 ) = 2 + CTOT( 1 )
+      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+*
+*     Fill out the IDXC array so that the permutation which it induces
+*     will place all type-1 columns first, all type-2 columns next,
+*     then all type-3's, and finally all type-4's, starting from the
+*     second column. This applies similarly to the rows of VT.
+*
+      DO 150 J = 2, N
+         JP = IDXP( J )
+         CT = COLTYP( JP )
+         IDXC( PSM( CT ) ) = J
+         PSM( CT ) = PSM( CT ) + 1
+  150 CONTINUE
+*
+*     Sort the singular values and corresponding singular vectors into
+*     DSIGMA, U2, and VT2 respectively.  The singular values/vectors
+*     which were not deflated go into the first K slots of DSIGMA, U2,
+*     and VT2 respectively, while those which were deflated go into the
+*     last N - K slots, except that the first column/row will be treated
+*     separately.
+*
+      DO 160 J = 2, N
+         JP = IDXP( J )
+         DSIGMA( J ) = D( JP )
+         IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
+         IF( IDXJ.LE.NLP1 ) THEN
+            IDXJ = IDXJ - 1
+         END IF
+         CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
+         CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
+  160 CONTINUE
+*
+*     Determine DSIGMA(1), DSIGMA(2) and Z(1)
+*
+      DSIGMA( 1 ) = ZERO
+      HLFTOL = TOL / TWO
+      IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+     $   DSIGMA( 2 ) = HLFTOL
+      IF( M.GT.N ) THEN
+         Z( 1 ) = DLAPY2( Z1, Z( M ) )
+         IF( Z( 1 ).LE.TOL ) THEN
+            C = ONE
+            S = ZERO
+            Z( 1 ) = TOL
+         ELSE
+            C = Z1 / Z( 1 )
+            S = Z( M ) / Z( 1 )
+         END IF
+      ELSE
+         IF( ABS( Z1 ).LE.TOL ) THEN
+            Z( 1 ) = TOL
+         ELSE
+            Z( 1 ) = Z1
+         END IF
+      END IF
+*
+*     Move the rest of the updating row to Z.
+*
+      CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
+*
+*     Determine the first column of U2, the first row of VT2 and the
+*     last row of VT.
+*
+      CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
+      U2( NLP1, 1 ) = ONE
+      IF( M.GT.N ) THEN
+         DO 170 I = 1, NLP1
+            VT( M, I ) = -S*VT( NLP1, I )
+            VT2( 1, I ) = C*VT( NLP1, I )
+  170    CONTINUE
+         DO 180 I = NLP2, M
+            VT2( 1, I ) = S*VT( M, I )
+            VT( M, I ) = C*VT( M, I )
+  180    CONTINUE
+      ELSE
+         CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
+      END IF
+      IF( M.GT.N ) THEN
+         CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
+      END IF
+*
+*     The deflated singular values and their corresponding vectors go
+*     into the back of D, U, and V respectively.
+*
+      IF( N.GT.K ) THEN
+         CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+         CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
+     $                LDU )
+         CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
+     $                LDVT )
+      END IF
+*
+*     Copy CTOT into COLTYP for referencing in DLASD3.
+*
+      DO 190 J = 1, 4
+         COLTYP( J ) = CTOT( J )
+  190 CONTINUE
+*
+      RETURN
+*
+*     End of DLASD2
+*
+      END
diff --git a/SRC/dlasd3.f b/SRC/dlasd3.f
new file mode 100644
index 00000000..d4124695
--- /dev/null
+++ b/SRC/dlasd3.f
@@ -0,0 +1,358 @@
+      SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
+     $                   LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
+     $                   SQRE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            CTOT( * ), IDXC( * )
+      DOUBLE PRECISION   D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
+     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+     $                   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASD3 finds all the square roots of the roots of the secular
+*  equation, as defined by the values in D and Z.  It makes the
+*  appropriate calls to DLASD4 and then updates the singular
+*  vectors by matrix multiplication.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  DLASD3 is called from DLASD1.
+*
+*  Arguments
+*  =========
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has N = NL + NR + 1 rows and
+*         M = N + SQRE >= N columns.
+*
+*  K      (input) INTEGER
+*         The size of the secular equation, 1 =< K = < N.
+*
+*  D      (output) DOUBLE PRECISION array, dimension(K)
+*         On exit the square roots of the roots of the secular equation,
+*         in ascending order.
+*
+*  Q      (workspace) DOUBLE PRECISION array,
+*                     dimension at least (LDQ,K).
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= K.
+*
+*  DSIGMA (input) DOUBLE PRECISION array, dimension(K)
+*         The first K elements of this array contain the old roots
+*         of the deflated updating problem.  These are the poles
+*         of the secular equation.
+*
+*  U      (output) DOUBLE PRECISION array, dimension (LDU, N)
+*         The last N - K columns of this matrix contain the deflated
+*         left singular vectors.
+*
+*  LDU    (input) INTEGER
+*         The leading dimension of the array U.  LDU >= N.
+*
+*  U2     (input/output) DOUBLE PRECISION array, dimension (LDU2, N)
+*         The first K columns of this matrix contain the non-deflated
+*         left singular vectors for the split problem.
+*
+*  LDU2   (input) INTEGER
+*         The leading dimension of the array U2.  LDU2 >= N.
+*
+*  VT     (output) DOUBLE PRECISION array, dimension (LDVT, M)
+*         The last M - K columns of VT' contain the deflated
+*         right singular vectors.
+*
+*  LDVT   (input) INTEGER
+*         The leading dimension of the array VT.  LDVT >= N.
+*
+*  VT2    (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)
+*         The first K columns of VT2' contain the non-deflated
+*         right singular vectors for the split problem.
+*
+*  LDVT2  (input) INTEGER
+*         The leading dimension of the array VT2.  LDVT2 >= N.
+*
+*  IDXC   (input) INTEGER array, dimension ( N )
+*         The permutation used to arrange the columns of U (and rows of
+*         VT) into three groups:  the first group contains non-zero
+*         entries only at and above (or before) NL +1; the second
+*         contains non-zero entries only at and below (or after) NL+2;
+*         and the third is dense. The first column of U and the row of
+*         VT are treated separately, however.
+*
+*         The rows of the singular vectors found by DLASD4
+*         must be likewise permuted before the matrix multiplies can
+*         take place.
+*
+*  CTOT   (input) INTEGER array, dimension ( 4 )
+*         A count of the total number of the various types of columns
+*         in U (or rows in VT), as described in IDXC. The fourth column
+*         type is any column which has been deflated.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension (K)
+*         The first K elements of this array contain the components
+*         of the deflation-adjusted updating row vector.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*         > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0,
+     $                   NEGONE = -1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
+      DOUBLE PRECISION   RHO, TEMP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3, DNRM2
+      EXTERNAL           DLAMC3, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( NL.LT.1 ) THEN
+         INFO = -1
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+         INFO = -3
+      END IF
+*
+      N = NL + NR + 1
+      M = N + SQRE
+      NLP1 = NL + 1
+      NLP2 = NL + 2
+*
+      IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.K ) THEN
+         INFO = -7
+      ELSE IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDU2.LT.N ) THEN
+         INFO = -12
+      ELSE IF( LDVT.LT.M ) THEN
+         INFO = -14
+      ELSE IF( LDVT2.LT.M ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD3', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.1 ) THEN
+         D( 1 ) = ABS( Z( 1 ) )
+         CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
+         IF( Z( 1 ).GT.ZERO ) THEN
+            CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
+         ELSE
+            DO 10 I = 1, N
+               U( I, 1 ) = -U2( I, 1 )
+   10       CONTINUE
+         END IF
+         RETURN
+      END IF
+*
+*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DSIGMA(I) if it is 1; this makes the subsequent
+*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DSIGMA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DSIGMA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DSIGMA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 20 I = 1, K
+         DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+   20 CONTINUE
+*
+*     Keep a copy of Z.
+*
+      CALL DCOPY( K, Z, 1, Q, 1 )
+*
+*     Normalize Z.
+*
+      RHO = DNRM2( K, Z, 1 )
+      CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+      RHO = RHO*RHO
+*
+*     Find the new singular values.
+*
+      DO 30 J = 1, K
+         CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
+     $                VT( 1, J ), INFO )
+*
+*        If the zero finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+   30 CONTINUE
+*
+*     Compute updated Z.
+*
+      DO 60 I = 1, K
+         Z( I ) = U( I, K )*VT( I, K )
+         DO 40 J = 1, I - 1
+            Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+     $               ( DSIGMA( I )-DSIGMA( J ) ) /
+     $               ( DSIGMA( I )+DSIGMA( J ) ) )
+   40    CONTINUE
+         DO 50 J = I, K - 1
+            Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+     $               ( DSIGMA( I )-DSIGMA( J+1 ) ) /
+     $               ( DSIGMA( I )+DSIGMA( J+1 ) ) )
+   50    CONTINUE
+         Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
+   60 CONTINUE
+*
+*     Compute left singular vectors of the modified diagonal matrix,
+*     and store related information for the right singular vectors.
+*
+      DO 90 I = 1, K
+         VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
+         U( 1, I ) = NEGONE
+         DO 70 J = 2, K
+            VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
+            U( J, I ) = DSIGMA( J )*VT( J, I )
+   70    CONTINUE
+         TEMP = DNRM2( K, U( 1, I ), 1 )
+         Q( 1, I ) = U( 1, I ) / TEMP
+         DO 80 J = 2, K
+            JC = IDXC( J )
+            Q( J, I ) = U( JC, I ) / TEMP
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Update the left singular vector matrix.
+*
+      IF( K.EQ.2 ) THEN
+         CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
+     $               LDU )
+         GO TO 100
+      END IF
+      IF( CTOT( 1 ).GT.0 ) THEN
+         CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
+     $               Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+         IF( CTOT( 3 ).GT.0 ) THEN
+            KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+            CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+     $                  LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
+         END IF
+      ELSE IF( CTOT( 3 ).GT.0 ) THEN
+         KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+         CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+     $               LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+      ELSE
+         CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU )
+      END IF
+      CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
+      KTEMP = 2 + CTOT( 1 )
+      CTEMP = CTOT( 2 ) + CTOT( 3 )
+      CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
+     $            Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
+*
+*     Generate the right singular vectors.
+*
+  100 CONTINUE
+      DO 120 I = 1, K
+         TEMP = DNRM2( K, VT( 1, I ), 1 )
+         Q( I, 1 ) = VT( 1, I ) / TEMP
+         DO 110 J = 2, K
+            JC = IDXC( J )
+            Q( I, J ) = VT( JC, I ) / TEMP
+  110    CONTINUE
+  120 CONTINUE
+*
+*     Update the right singular vector matrix.
+*
+      IF( K.EQ.2 ) THEN
+         CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
+     $               VT, LDVT )
+         RETURN
+      END IF
+      KTEMP = 1 + CTOT( 1 )
+      CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
+     $            VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
+      KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+      IF( KTEMP.LE.LDVT2 )
+     $   CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
+     $               LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
+     $               LDVT )
+*
+      KTEMP = CTOT( 1 ) + 1
+      NRP1 = NR + SQRE
+      IF( KTEMP.GT.1 ) THEN
+         DO 130 I = 1, K
+            Q( I, KTEMP ) = Q( I, 1 )
+  130    CONTINUE
+         DO 140 I = NLP2, M
+            VT2( KTEMP, I ) = VT2( 1, I )
+  140    CONTINUE
+      END IF
+      CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
+      CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
+     $            VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
+*
+      RETURN
+*
+*     End of DLASD3
+*
+      END
diff --git a/SRC/dlasd4.f b/SRC/dlasd4.f
new file mode 100644
index 00000000..795639fd
--- /dev/null
+++ b/SRC/dlasd4.f
@@ -0,0 +1,890 @@
+      SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I, INFO, N
+      DOUBLE PRECISION   RHO, SIGMA
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), DELTA( * ), WORK( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the square root of the I-th updated
+*  eigenvalue of a positive symmetric rank-one modification to
+*  a positive diagonal matrix whose entries are given as the squares
+*  of the corresponding entries in the array d, and that
+*
+*         0 <= D(i) < D(j)  for  i < j
+*
+*  and that RHO > 0. This is arranged by the calling routine, and is
+*  no loss in generality.  The rank-one modified system is thus
+*
+*         diag( D ) * diag( D ) +  RHO *  Z * Z_transpose.
+*
+*  where we assume the Euclidean norm of Z is 1.
+*
+*  The method consists of approximating the rational functions in the
+*  secular equation by simpler interpolating rational functions.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The length of all arrays.
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  1 <= I <= N.
+*
+*  D      (input) DOUBLE PRECISION array, dimension ( N )
+*         The original eigenvalues.  It is assumed that they are in
+*         order, 0 <= D(I) < D(J)  for I < J.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( N )
+*         The components of the updating vector.
+*
+*  DELTA  (output) DOUBLE PRECISION array, dimension ( N )
+*         If N .ne. 1, DELTA contains (D(j) - sigma_I) in its  j-th
+*         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA
+*         contains the information necessary to construct the
+*         (singular) eigenvectors.
+*
+*  RHO    (input) DOUBLE PRECISION
+*         The scalar in the symmetric updating formula.
+*
+*  SIGMA  (output) DOUBLE PRECISION
+*         The computed sigma_I, the I-th updated eigenvalue.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension ( N )
+*         If N .ne. 1, WORK contains (D(j) + sigma_I) in its  j-th
+*         component.  If N = 1, then WORK( 1 ) = 1.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit
+*         > 0:  if INFO = 1, the updating process failed.
+*
+*  Internal Parameters
+*  ===================
+*
+*  Logical variable ORGATI (origin-at-i?) is used for distinguishing
+*  whether D(i) or D(i+1) is treated as the origin.
+*
+*            ORGATI = .true.    origin at i
+*            ORGATI = .false.   origin at i+1
+*
+*  Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+*  if we are working with THREE poles!
+*
+*  MAXIT is the maximum number of iterations allowed for each
+*  eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 20 )
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+     $                   THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0,
+     $                   TEN = 10.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ORGATI, SWTCH, SWTCH3
+      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
+      DOUBLE PRECISION   A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
+     $                   DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
+     $                   ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
+     $                   SG2UB, TAU, TEMP, TEMP1, TEMP2, W
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DD( 3 ), ZZ( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAED6, DLASD5
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Since this routine is called in an inner loop, we do no argument
+*     checking.
+*
+*     Quick return for N=1 and 2.
+*
+      INFO = 0
+      IF( N.EQ.1 ) THEN
+*
+*        Presumably, I=1 upon entry
+*
+         SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
+         DELTA( 1 ) = ONE
+         WORK( 1 ) = ONE
+         RETURN
+      END IF
+      IF( N.EQ.2 ) THEN
+         CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
+         RETURN
+      END IF
+*
+*     Compute machine epsilon
+*
+      EPS = DLAMCH( 'Epsilon' )
+      RHOINV = ONE / RHO
+*
+*     The case I = N
+*
+      IF( I.EQ.N ) THEN
+*
+*        Initialize some basic variables
+*
+         II = N - 1
+         NITER = 1
+*
+*        Calculate initial guess
+*
+         TEMP = RHO / TWO
+*
+*        If ||Z||_2 is not one, then TEMP should be set to
+*        RHO * ||Z||_2^2 / TWO
+*
+         TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
+         DO 10 J = 1, N
+            WORK( J ) = D( J ) + D( N ) + TEMP1
+            DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
+   10    CONTINUE
+*
+         PSI = ZERO
+         DO 20 J = 1, N - 2
+            PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
+   20    CONTINUE
+*
+         C = RHOINV + PSI
+         W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
+     $       Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
+*
+         IF( W.LE.ZERO ) THEN
+            TEMP1 = SQRT( D( N )*D( N )+RHO )
+            TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
+     $             ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
+     $             Z( N )*Z( N ) / RHO
+*
+*           The following TAU is to approximate
+*           SIGMA_n^2 - D( N )*D( N )
+*
+            IF( C.LE.TEMP ) THEN
+               TAU = RHO
+            ELSE
+               DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+               A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+               B = Z( N )*Z( N )*DELSQ
+               IF( A.LT.ZERO ) THEN
+                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+               ELSE
+                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+               END IF
+            END IF
+*
+*           It can be proved that
+*               D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
+*
+         ELSE
+            DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+            A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+            B = Z( N )*Z( N )*DELSQ
+*
+*           The following TAU is to approximate
+*           SIGMA_n^2 - D( N )*D( N )
+*
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+            ELSE
+               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+            END IF
+*
+*           It can be proved that
+*           D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
+*
+         END IF
+*
+*        The following ETA is to approximate SIGMA_n - D( N )
+*
+         ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
+*
+         SIGMA = D( N ) + ETA
+         DO 30 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - ETA
+            WORK( J ) = D( J ) + D( I ) + ETA
+   30    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 40 J = 1, II
+            TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   40    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            GO TO 240
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+         DTNSQ = WORK( N )*DELTA( N )
+         C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+         A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
+         B = DTNSQ*DTNSQ1*W
+         IF( C.LT.ZERO )
+     $      C = ABS( C )
+         IF( C.EQ.ZERO ) THEN
+            ETA = RHO - SIGMA*SIGMA
+         ELSE IF( A.GE.ZERO ) THEN
+            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GT.ZERO )
+     $      ETA = -W / ( DPSI+DPHI )
+         TEMP = ETA - DTNSQ
+         IF( TEMP.GT.RHO )
+     $      ETA = RHO + DTNSQ
+*
+         TAU = TAU + ETA
+         ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+         DO 50 J = 1, N
+            DELTA( J ) = DELTA( J ) - ETA
+            WORK( J ) = WORK( J ) + ETA
+   50    CONTINUE
+*
+         SIGMA = SIGMA + ETA
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 60 J = 1, II
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   60    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Main loop to update the values of the array   DELTA
+*
+         ITER = NITER + 1
+*
+         DO 90 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               GO TO 240
+            END IF
+*
+*           Calculate the new step
+*
+            DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+            DTNSQ = WORK( N )*DELTA( N )
+            C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+            A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
+            B = DTNSQ1*DTNSQ*W
+            IF( A.GE.ZERO ) THEN
+               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GT.ZERO )
+     $         ETA = -W / ( DPSI+DPHI )
+            TEMP = ETA - DTNSQ
+            IF( TEMP.LE.ZERO )
+     $         ETA = ETA / TWO
+*
+            TAU = TAU + ETA
+            ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+            DO 70 J = 1, N
+               DELTA( J ) = DELTA( J ) - ETA
+               WORK( J ) = WORK( J ) + ETA
+   70       CONTINUE
+*
+            SIGMA = SIGMA + ETA
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 80 J = 1, II
+               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+   80       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+            PHI = Z( N )*TEMP
+            DPHI = TEMP*TEMP
+            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $               ABS( TAU )*( DPSI+DPHI )
+*
+            W = RHOINV + PHI + PSI
+   90    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+         GO TO 240
+*
+*        End for the case I = N
+*
+      ELSE
+*
+*        The case for I < N
+*
+         NITER = 1
+         IP1 = I + 1
+*
+*        Calculate initial guess
+*
+         DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
+         DELSQ2 = DELSQ / TWO
+         TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
+         DO 100 J = 1, N
+            WORK( J ) = D( J ) + D( I ) + TEMP
+            DELTA( J ) = ( D( J )-D( I ) ) - TEMP
+  100    CONTINUE
+*
+         PSI = ZERO
+         DO 110 J = 1, I - 1
+            PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+  110    CONTINUE
+*
+         PHI = ZERO
+         DO 120 J = N, I + 2, -1
+            PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+  120    CONTINUE
+         C = RHOINV + PSI + PHI
+         W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
+     $       Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
+*
+         IF( W.GT.ZERO ) THEN
+*
+*           d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
+*
+*           We choose d(i) as origin.
+*
+            ORGATI = .TRUE.
+            SG2LB = ZERO
+            SG2UB = DELSQ2
+            A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+            B = Z( I )*Z( I )*DELSQ
+            IF( A.GT.ZERO ) THEN
+               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            ELSE
+               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+*
+*           TAU now is an estimation of SIGMA^2 - D( I )^2. The
+*           following, however, is the corresponding estimation of
+*           SIGMA - D( I ).
+*
+            ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
+         ELSE
+*
+*           (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
+*
+*           We choose d(i+1) as origin.
+*
+            ORGATI = .FALSE.
+            SG2LB = -DELSQ2
+            SG2UB = ZERO
+            A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+            B = Z( IP1 )*Z( IP1 )*DELSQ
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+            ELSE
+               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+*
+*           TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
+*           following, however, is the corresponding estimation of
+*           SIGMA - D( IP1 ).
+*
+            ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
+     $            TAU ) ) )
+         END IF
+*
+         IF( ORGATI ) THEN
+            II = I
+            SIGMA = D( I ) + ETA
+            DO 130 J = 1, N
+               WORK( J ) = D( J ) + D( I ) + ETA
+               DELTA( J ) = ( D( J )-D( I ) ) - ETA
+  130       CONTINUE
+         ELSE
+            II = I + 1
+            SIGMA = D( IP1 ) + ETA
+            DO 140 J = 1, N
+               WORK( J ) = D( J ) + D( IP1 ) + ETA
+               DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
+  140       CONTINUE
+         END IF
+         IIM1 = II - 1
+         IIP1 = II + 1
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 150 J = 1, IIM1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  150    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 160 J = N, IIP1, -1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  160    CONTINUE
+*
+         W = RHOINV + PHI + PSI
+*
+*        W is the value of the secular function with
+*        its ii-th element removed.
+*
+         SWTCH3 = .FALSE.
+         IF( ORGATI ) THEN
+            IF( W.LT.ZERO )
+     $         SWTCH3 = .TRUE.
+         ELSE
+            IF( W.GT.ZERO )
+     $         SWTCH3 = .TRUE.
+         END IF
+         IF( II.EQ.1 .OR. II.EQ.N )
+     $      SWTCH3 = .FALSE.
+*
+         TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = W + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            GO TO 240
+         END IF
+*
+         IF( W.LE.ZERO ) THEN
+            SG2LB = MAX( SG2LB, TAU )
+         ELSE
+            SG2UB = MIN( SG2UB, TAU )
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         IF( .NOT.SWTCH3 ) THEN
+            DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+            DTISQ = WORK( I )*DELTA( I )
+            IF( ORGATI ) THEN
+               C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+            ELSE
+               C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+            END IF
+            A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+            B = DTIPSQ*DTISQ*W
+            IF( C.EQ.ZERO ) THEN
+               IF( A.EQ.ZERO ) THEN
+                  IF( ORGATI ) THEN
+                     A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
+                  ELSE
+                     A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
+                  END IF
+               END IF
+               ETA = B / A
+            ELSE IF( A.LE.ZERO ) THEN
+               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+         ELSE
+*
+*           Interpolation using THREE most relevant poles
+*
+            DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+            DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+            TEMP = RHOINV + PSI + PHI
+            IF( ORGATI ) THEN
+               TEMP1 = Z( IIM1 ) / DTIIM
+               TEMP1 = TEMP1*TEMP1
+               C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
+     $             ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+               IF( DPSI.LT.TEMP1 ) THEN
+                  ZZ( 3 ) = DTIIP*DTIIP*DPHI
+               ELSE
+                  ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+               END IF
+            ELSE
+               TEMP1 = Z( IIP1 ) / DTIIP
+               TEMP1 = TEMP1*TEMP1
+               C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
+     $             ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+               IF( DPHI.LT.TEMP1 ) THEN
+                  ZZ( 1 ) = DTIIM*DTIIM*DPSI
+               ELSE
+                  ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+               END IF
+               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+            END IF
+            ZZ( 2 ) = Z( II )*Z( II )
+            DD( 1 ) = DTIIM
+            DD( 2 ) = DELTA( II )*WORK( II )
+            DD( 3 ) = DTIIP
+            CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 240
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GE.ZERO )
+     $      ETA = -W / DW
+         IF( ORGATI ) THEN
+            TEMP1 = WORK( I )*DELTA( I )
+            TEMP = ETA - TEMP1
+         ELSE
+            TEMP1 = WORK( IP1 )*DELTA( IP1 )
+            TEMP = ETA - TEMP1
+         END IF
+         IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+            IF( W.LT.ZERO ) THEN
+               ETA = ( SG2UB-TAU ) / TWO
+            ELSE
+               ETA = ( SG2LB-TAU ) / TWO
+            END IF
+         END IF
+*
+         TAU = TAU + ETA
+         ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+         PREW = W
+*
+         SIGMA = SIGMA + ETA
+         DO 170 J = 1, N
+            WORK( J ) = WORK( J ) + ETA
+            DELTA( J ) = DELTA( J ) - ETA
+  170    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 180 J = 1, IIM1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  180    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 190 J = N, IIP1, -1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  190    CONTINUE
+*
+         TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = RHOINV + PHI + PSI + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+         IF( W.LE.ZERO ) THEN
+            SG2LB = MAX( SG2LB, TAU )
+         ELSE
+            SG2UB = MIN( SG2UB, TAU )
+         END IF
+*
+         SWTCH = .FALSE.
+         IF( ORGATI ) THEN
+            IF( -W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         ELSE
+            IF( W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         END IF
+*
+*        Main loop to update the values of the array   DELTA and WORK
+*
+         ITER = NITER + 1
+*
+         DO 230 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               GO TO 240
+            END IF
+*
+*           Calculate the new step
+*
+            IF( .NOT.SWTCH3 ) THEN
+               DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+               DTISQ = WORK( I )*DELTA( I )
+               IF( .NOT.SWTCH ) THEN
+                  IF( ORGATI ) THEN
+                     C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+                  ELSE
+                     C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+                  END IF
+               ELSE
+                  TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+                  IF( ORGATI ) THEN
+                     DPSI = DPSI + TEMP*TEMP
+                  ELSE
+                     DPHI = DPHI + TEMP*TEMP
+                  END IF
+                  C = W - DTISQ*DPSI - DTIPSQ*DPHI
+               END IF
+               A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+               B = DTIPSQ*DTISQ*W
+               IF( C.EQ.ZERO ) THEN
+                  IF( A.EQ.ZERO ) THEN
+                     IF( .NOT.SWTCH ) THEN
+                        IF( ORGATI ) THEN
+                           A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
+     $                         ( DPSI+DPHI )
+                        ELSE
+                           A = Z( IP1 )*Z( IP1 ) +
+     $                         DTISQ*DTISQ*( DPSI+DPHI )
+                        END IF
+                     ELSE
+                        A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
+                     END IF
+                  END IF
+                  ETA = B / A
+               ELSE IF( A.LE.ZERO ) THEN
+                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+               ELSE
+                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+               END IF
+            ELSE
+*
+*              Interpolation using THREE most relevant poles
+*
+               DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+               DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+               TEMP = RHOINV + PSI + PHI
+               IF( SWTCH ) THEN
+                  C = TEMP - DTIIM*DPSI - DTIIP*DPHI
+                  ZZ( 1 ) = DTIIM*DTIIM*DPSI
+                  ZZ( 3 ) = DTIIP*DTIIP*DPHI
+               ELSE
+                  IF( ORGATI ) THEN
+                     TEMP1 = Z( IIM1 ) / DTIIM
+                     TEMP1 = TEMP1*TEMP1
+                     TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
+     $                       ( D( IIM1 )+D( IIP1 ) )*TEMP1
+                     C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
+                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+                     IF( DPSI.LT.TEMP1 ) THEN
+                        ZZ( 3 ) = DTIIP*DTIIP*DPHI
+                     ELSE
+                        ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+                     END IF
+                  ELSE
+                     TEMP1 = Z( IIP1 ) / DTIIP
+                     TEMP1 = TEMP1*TEMP1
+                     TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
+     $                       ( D( IIM1 )+D( IIP1 ) )*TEMP1
+                     C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
+                     IF( DPHI.LT.TEMP1 ) THEN
+                        ZZ( 1 ) = DTIIM*DTIIM*DPSI
+                     ELSE
+                        ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+                     END IF
+                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+                  END IF
+               END IF
+               DD( 1 ) = DTIIM
+               DD( 2 ) = DELTA( II )*WORK( II )
+               DD( 3 ) = DTIIP
+               CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 240
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GE.ZERO )
+     $         ETA = -W / DW
+            IF( ORGATI ) THEN
+               TEMP1 = WORK( I )*DELTA( I )
+               TEMP = ETA - TEMP1
+            ELSE
+               TEMP1 = WORK( IP1 )*DELTA( IP1 )
+               TEMP = ETA - TEMP1
+            END IF
+            IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+               IF( W.LT.ZERO ) THEN
+                  ETA = ( SG2UB-TAU ) / TWO
+               ELSE
+                  ETA = ( SG2LB-TAU ) / TWO
+               END IF
+            END IF
+*
+            TAU = TAU + ETA
+            ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+            SIGMA = SIGMA + ETA
+            DO 200 J = 1, N
+               WORK( J ) = WORK( J ) + ETA
+               DELTA( J ) = DELTA( J ) - ETA
+  200       CONTINUE
+*
+            PREW = W
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 210 J = 1, IIM1
+               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+  210       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            DPHI = ZERO
+            PHI = ZERO
+            DO 220 J = N, IIP1, -1
+               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+               PHI = PHI + Z( J )*TEMP
+               DPHI = DPHI + TEMP*TEMP
+               ERRETM = ERRETM + PHI
+  220       CONTINUE
+*
+            TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+            DW = DPSI + DPHI + TEMP*TEMP
+            TEMP = Z( II )*TEMP
+            W = RHOINV + PHI + PSI + TEMP
+            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $               THREE*ABS( TEMP ) + ABS( TAU )*DW
+            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+     $         SWTCH = .NOT.SWTCH
+*
+            IF( W.LE.ZERO ) THEN
+               SG2LB = MAX( SG2LB, TAU )
+            ELSE
+               SG2UB = MIN( SG2UB, TAU )
+            END IF
+*
+  230    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+*
+      END IF
+*
+  240 CONTINUE
+      RETURN
+*
+*     End of DLASD4
+*
+      END
diff --git a/SRC/dlasd5.f b/SRC/dlasd5.f
new file mode 100644
index 00000000..93cb847d
--- /dev/null
+++ b/SRC/dlasd5.f
@@ -0,0 +1,163 @@
+      SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I
+      DOUBLE PRECISION   DSIGMA, RHO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the square root of the I-th eigenvalue
+*  of a positive symmetric rank-one modification of a 2-by-2 diagonal
+*  matrix
+*
+*             diag( D ) * diag( D ) +  RHO *  Z * transpose(Z) .
+*
+*  The diagonal entries in the array D are assumed to satisfy
+*
+*             0 <= D(i) < D(j)  for  i < j .
+*
+*  We also assume RHO > 0 and that the Euclidean norm of the vector
+*  Z is one.
+*
+*  Arguments
+*  =========
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  I = 1 or I = 2.
+*
+*  D      (input) DOUBLE PRECISION array, dimension ( 2 )
+*         The original eigenvalues.  We assume 0 <= D(1) < D(2).
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( 2 )
+*         The components of the updating vector.
+*
+*  DELTA  (output) DOUBLE PRECISION array, dimension ( 2 )
+*         Contains (D(j) - sigma_I) in its  j-th component.
+*         The vector DELTA contains the information necessary
+*         to construct the eigenvectors.
+*
+*  RHO    (input) DOUBLE PRECISION
+*         The scalar in the symmetric updating formula.
+*
+*  DSIGMA (output) DOUBLE PRECISION
+*         The computed sigma_I, the I-th updated eigenvalue.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension ( 2 )
+*         WORK contains (D(j) + sigma_I) in its  j-th component.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+     $                   THREE = 3.0D+0, FOUR = 4.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   B, C, DEL, DELSQ, TAU, W
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      DEL = D( 2 ) - D( 1 )
+      DELSQ = DEL*( D( 2 )+D( 1 ) )
+      IF( I.EQ.1 ) THEN
+         W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
+     $       Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
+         IF( W.GT.ZERO ) THEN
+            B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 1 )*Z( 1 )*DELSQ
+*
+*           B > ZERO, always
+*
+*           The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
+*
+            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+*
+*           The following TAU is DSIGMA - D( 1 )
+*
+            TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
+            DSIGMA = D( 1 ) + TAU
+            DELTA( 1 ) = -TAU
+            DELTA( 2 ) = DEL - TAU
+            WORK( 1 ) = TWO*D( 1 ) + TAU
+            WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
+*           DELTA( 1 ) = -Z( 1 ) / TAU
+*           DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+         ELSE
+            B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+*           The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+            IF( B.GT.ZERO ) THEN
+               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+            ELSE
+               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+            END IF
+*
+*           The following TAU is DSIGMA - D( 2 )
+*
+            TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
+            DSIGMA = D( 2 ) + TAU
+            DELTA( 1 ) = -( DEL+TAU )
+            DELTA( 2 ) = -TAU
+            WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+            WORK( 2 ) = TWO*D( 2 ) + TAU
+*           DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+*           DELTA( 2 ) = -Z( 2 ) / TAU
+         END IF
+*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+*        DELTA( 1 ) = DELTA( 1 ) / TEMP
+*        DELTA( 2 ) = DELTA( 2 ) / TEMP
+      ELSE
+*
+*        Now I=2
+*
+         B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+         C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+*        The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+         IF( B.GT.ZERO ) THEN
+            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+         ELSE
+            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+         END IF
+*
+*        The following TAU is DSIGMA - D( 2 )
+*
+         TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
+         DSIGMA = D( 2 ) + TAU
+         DELTA( 1 ) = -( DEL+TAU )
+         DELTA( 2 ) = -TAU
+         WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+         WORK( 2 ) = TWO*D( 2 ) + TAU
+*        DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+*        DELTA( 2 ) = -Z( 2 ) / TAU
+*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+*        DELTA( 1 ) = DELTA( 1 ) / TEMP
+*        DELTA( 2 ) = DELTA( 2 ) / TEMP
+      END IF
+      RETURN
+*
+*     End of DLASD5
+*
+      END
diff --git a/SRC/dlasd6.f b/SRC/dlasd6.f
new file mode 100644
index 00000000..622befaa
--- /dev/null
+++ b/SRC/dlasd6.f
@@ -0,0 +1,305 @@
+      SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
+     $                   IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
+     $                   LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+     $                   NR, SQRE
+      DOUBLE PRECISION   ALPHA, BETA, C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
+     $                   PERM( * )
+      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( * ),
+     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
+     $                   VF( * ), VL( * ), WORK( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASD6 computes the SVD of an updated upper bidiagonal matrix B
+*  obtained by merging two smaller ones by appending a row. This
+*  routine is used only for the problem which requires all singular
+*  values and optionally singular vector matrices in factored form.
+*  B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
+*  A related subroutine, DLASD1, handles the case in which all singular
+*  values and singular vectors of the bidiagonal matrix are desired.
+*
+*  DLASD6 computes the SVD as follows:
+*
+*                ( D1(in)  0    0     0 )
+*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
+*                (   0     0   D2(in) 0 )
+*
+*      = U(out) * ( D(out) 0) * VT(out)
+*
+*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+*  elsewhere; and the entry b is empty if SQRE = 0.
+*
+*  The singular values of B can be computed using D1, D2, the first
+*  components of all the right singular vectors of the lower block, and
+*  the last components of all the right singular vectors of the upper
+*  block. These components are stored and updated in VF and VL,
+*  respectively, in DLASD6. Hence U and VT are not explicitly
+*  referenced.
+*
+*  The singular values are stored in D. The algorithm consists of two
+*  stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple singular values or if there is a zero
+*        in the Z vector. For each such occurence the dimension of the
+*        secular equation problem is reduced by one. This stage is
+*        performed by the routine DLASD7.
+*
+*        The second stage consists of calculating the updated
+*        singular values. This is done by finding the roots of the
+*        secular equation via the routine DLASD4 (as called by DLASD8).
+*        This routine also updates VF and VL and computes the distances
+*        between the updated singular values and the old singular
+*        values.
+*
+*  DLASD6 is called from DLASDA.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed in
+*         factored form:
+*         = 0: Compute singular values only.
+*         = 1: Compute singular vectors in factored form as well.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).
+*         On entry D(1:NL,1:NL) contains the singular values of the
+*         upper block, and D(NL+2:N) contains the singular values
+*         of the lower block. On exit D(1:N) contains the singular
+*         values of the modified matrix.
+*
+*  VF     (input/output) DOUBLE PRECISION array, dimension ( M )
+*         On entry, VF(1:NL+1) contains the first components of all
+*         right singular vectors of the upper block; and VF(NL+2:M)
+*         contains the first components of all right singular vectors
+*         of the lower block. On exit, VF contains the first components
+*         of all right singular vectors of the bidiagonal matrix.
+*
+*  VL     (input/output) DOUBLE PRECISION array, dimension ( M )
+*         On entry, VL(1:NL+1) contains the  last components of all
+*         right singular vectors of the upper block; and VL(NL+2:M)
+*         contains the last components of all right singular vectors of
+*         the lower block. On exit, VL contains the last components of
+*         all right singular vectors of the bidiagonal matrix.
+*
+*  ALPHA  (input/output) DOUBLE PRECISION
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input/output) DOUBLE PRECISION
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  IDXQ   (output) INTEGER array, dimension ( N )
+*         This contains the permutation which will reintegrate the
+*         subproblem just solved back into sorted order, i.e.
+*         D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  PERM   (output) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) to be applied
+*         to each block. Not referenced if ICOMPQ = 0.
+*
+*  GIVPTR (output) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem. Not referenced if ICOMPQ = 0.
+*
+*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGCOL (input) INTEGER
+*         leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value to be used in the
+*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of GIVNUM and POLES, must be at least N.
+*
+*  POLES  (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         On exit, POLES(1,*) is an array containing the new singular
+*         values obtained from solving the secular equation, and
+*         POLES(2,*) is an array containing the poles in the secular
+*         equation. Not referenced if ICOMPQ = 0.
+*
+*  DIFL   (output) DOUBLE PRECISION array, dimension ( N )
+*         On exit, DIFL(I) is the distance between I-th updated
+*         (undeflated) singular value and the I-th (undeflated) old
+*         singular value.
+*
+*  DIFR   (output) DOUBLE PRECISION array,
+*                  dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
+*                  dimension ( N ) if ICOMPQ = 0.
+*         On exit, DIFR(I, 1) is the distance between I-th updated
+*         (undeflated) singular value and the I+1-th (undeflated) old
+*         singular value.
+*
+*         If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+*         normalizing factors for the right singular vector matrix.
+*
+*         See DLASD8 for details on DIFL and DIFR.
+*
+*  Z      (output) DOUBLE PRECISION array, dimension ( M )
+*         The first elements of this array contain the components
+*         of the deflation-adjusted updating row vector.
+*
+*  K      (output) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  C      (output) DOUBLE PRECISION
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (output) DOUBLE PRECISION
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension ( 4 * M )
+*
+*  IWORK  (workspace) INTEGER 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 = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
+     $                   N, N1, N2
+      DOUBLE PRECISION   ORGNRM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      N = NL + NR + 1
+      M = N + SQRE
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -14
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD6', -INFO )
+         RETURN
+      END IF
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in DLASD7 and DLASD8.
+*
+      ISIGMA = 1
+      IW = ISIGMA + N
+      IVFW = IW + M
+      IVLW = IVFW + M
+*
+      IDX = 1
+      IDXC = IDX + N
+      IDXP = IDXC + N
+*
+*     Scale.
+*
+      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+      D( NL+1 ) = ZERO
+      DO 10 I = 1, N
+         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+            ORGNRM = ABS( D( I ) )
+         END IF
+   10 CONTINUE
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      ALPHA = ALPHA / ORGNRM
+      BETA = BETA / ORGNRM
+*
+*     Sort and Deflate singular values.
+*
+      CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
+     $             WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
+     $             WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
+     $             PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
+     $             INFO )
+*
+*     Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
+*
+      CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
+     $             WORK( ISIGMA ), WORK( IW ), INFO )
+*
+*     Save the poles if ICOMPQ = 1.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 )
+         CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
+      END IF
+*
+*     Unscale.
+*
+      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+*     Prepare the IDXQ sorting permutation.
+*
+      N1 = K
+      N2 = N - K
+      CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+      RETURN
+*
+*     End of DLASD6
+*
+      END
diff --git a/SRC/dlasd7.f b/SRC/dlasd7.f
new file mode 100644
index 00000000..27547aaa
--- /dev/null
+++ b/SRC/dlasd7.f
@@ -0,0 +1,444 @@
+      SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
+     $                   VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
+     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
+     $                   C, S, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+     $                   NR, SQRE
+      DOUBLE PRECISION   ALPHA, BETA, C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
+     $                   IDXQ( * ), PERM( * )
+      DOUBLE PRECISION   D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
+     $                   VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
+     $                   ZW( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASD7 merges the two sets of singular values together into a single
+*  sorted set. Then it tries to deflate the size of the problem. There
+*  are two ways in which deflation can occur:  when two or more singular
+*  values are close together or if there is a tiny entry in the Z
+*  vector. For each such occurrence the order of the related
+*  secular equation problem is reduced by one.
+*
+*  DLASD7 is called from DLASD6.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          Specifies whether singular vectors are to be computed
+*          in compact form, as follows:
+*          = 0: Compute singular values only.
+*          = 1: Compute singular vectors of upper
+*               bidiagonal matrix in compact form.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block. NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block. NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has
+*         N = NL + NR + 1 rows and
+*         M = N + SQRE >= N columns.
+*
+*  K      (output) INTEGER
+*         Contains the dimension of the non-deflated matrix, this is
+*         the order of the related secular equation. 1 <= K <=N.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension ( N )
+*         On entry D contains the singular values of the two submatrices
+*         to be combined. On exit D contains the trailing (N-K) updated
+*         singular values (those which were deflated) sorted into
+*         increasing order.
+*
+*  Z      (output) DOUBLE PRECISION array, dimension ( M )
+*         On exit Z contains the updating row vector in the secular
+*         equation.
+*
+*  ZW     (workspace) DOUBLE PRECISION array, dimension ( M )
+*         Workspace for Z.
+*
+*  VF     (input/output) DOUBLE PRECISION array, dimension ( M )
+*         On entry, VF(1:NL+1) contains the first components of all
+*         right singular vectors of the upper block; and VF(NL+2:M)
+*         contains the first components of all right singular vectors
+*         of the lower block. On exit, VF contains the first components
+*         of all right singular vectors of the bidiagonal matrix.
+*
+*  VFW    (workspace) DOUBLE PRECISION array, dimension ( M )
+*         Workspace for VF.
+*
+*  VL     (input/output) DOUBLE PRECISION array, dimension ( M )
+*         On entry, VL(1:NL+1) contains the  last components of all
+*         right singular vectors of the upper block; and VL(NL+2:M)
+*         contains the last components of all right singular vectors
+*         of the lower block. On exit, VL contains the last components
+*         of all right singular vectors of the bidiagonal matrix.
+*
+*  VLW    (workspace) DOUBLE PRECISION array, dimension ( M )
+*         Workspace for VL.
+*
+*  ALPHA  (input) DOUBLE PRECISION
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input) DOUBLE PRECISION
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  DSIGMA (output) DOUBLE PRECISION array, dimension ( N )
+*         Contains a copy of the diagonal elements (K-1 singular values
+*         and one zero) in the secular equation.
+*
+*  IDX    (workspace) INTEGER array, dimension ( N )
+*         This will contain the permutation used to sort the contents of
+*         D into ascending order.
+*
+*  IDXP   (workspace) INTEGER array, dimension ( N )
+*         This will contain the permutation used to place deflated
+*         values of D at the end of the array. On output IDXP(2:K)
+*         points to the nondeflated D-values and IDXP(K+1:N)
+*         points to the deflated singular values.
+*
+*  IDXQ   (input) INTEGER array, dimension ( N )
+*         This contains the permutation which separately sorts the two
+*         sub-problems in D into ascending order.  Note that entries in
+*         the first half of this permutation must first be moved one
+*         position backward; and entries in the second half
+*         must first have NL+1 added to their values.
+*
+*  PERM   (output) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) to be applied
+*         to each singular block. Not referenced if ICOMPQ = 0.
+*
+*  GIVPTR (output) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem. Not referenced if ICOMPQ = 0.
+*
+*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGCOL (input) INTEGER
+*         The leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value to be used in the
+*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of GIVNUM, must be at least N.
+*
+*  C      (output) DOUBLE PRECISION
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (output) DOUBLE PRECISION
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+     $                   EIGHT = 8.0D+0 )
+*     ..
+*     .. Local Scalars ..
+*
+      INTEGER            I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
+     $                   NLP1, NLP2
+      DOUBLE PRECISION   EPS, HLFTOL, TAU, TOL, Z1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAMRG, DROT, XERBLA
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           DLAMCH, DLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      N = NL + NR + 1
+      M = N + SQRE
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -22
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -24
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD7', -INFO )
+         RETURN
+      END IF
+*
+      NLP1 = NL + 1
+      NLP2 = NL + 2
+      IF( ICOMPQ.EQ.1 ) THEN
+         GIVPTR = 0
+      END IF
+*
+*     Generate the first part of the vector Z and move the singular
+*     values in the first part of D one position backward.
+*
+      Z1 = ALPHA*VL( NLP1 )
+      VL( NLP1 ) = ZERO
+      TAU = VF( NLP1 )
+      DO 10 I = NL, 1, -1
+         Z( I+1 ) = ALPHA*VL( I )
+         VL( I ) = ZERO
+         VF( I+1 ) = VF( I )
+         D( I+1 ) = D( I )
+         IDXQ( I+1 ) = IDXQ( I ) + 1
+   10 CONTINUE
+      VF( 1 ) = TAU
+*
+*     Generate the second part of the vector Z.
+*
+      DO 20 I = NLP2, M
+         Z( I ) = BETA*VF( I )
+         VF( I ) = ZERO
+   20 CONTINUE
+*
+*     Sort the singular values into increasing order
+*
+      DO 30 I = NLP2, N
+         IDXQ( I ) = IDXQ( I ) + NLP1
+   30 CONTINUE
+*
+*     DSIGMA, IDXC, IDXC, and ZW are used as storage space.
+*
+      DO 40 I = 2, N
+         DSIGMA( I ) = D( IDXQ( I ) )
+         ZW( I ) = Z( IDXQ( I ) )
+         VFW( I ) = VF( IDXQ( I ) )
+         VLW( I ) = VL( IDXQ( I ) )
+   40 CONTINUE
+*
+      CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+      DO 50 I = 2, N
+         IDXI = 1 + IDX( I )
+         D( I ) = DSIGMA( IDXI )
+         Z( I ) = ZW( IDXI )
+         VF( I ) = VFW( IDXI )
+         VL( I ) = VLW( IDXI )
+   50 CONTINUE
+*
+*     Calculate the allowable deflation tolerence
+*
+      EPS = DLAMCH( 'Epsilon' )
+      TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+      TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+*     There are 2 kinds of deflation -- first a value in the z-vector
+*     is small, second two (or more) singular values are very close
+*     together (their difference is small).
+*
+*     If the value in the z-vector is small, we simply permute the
+*     array so that the corresponding singular value is moved to the
+*     end.
+*
+*     If two values in the D-vector are close, we perform a two-sided
+*     rotation designed to make one of the corresponding z-vector
+*     entries zero, and then permute the array so that the deflated
+*     singular value is moved to the end.
+*
+*     If there are multiple singular values then the problem deflates.
+*     Here the number of equal singular values are found.  As each equal
+*     singular value is found, an elementary reflector is computed to
+*     rotate the corresponding singular subspace so that the
+*     corresponding components of Z are zero in this new basis.
+*
+      K = 1
+      K2 = N + 1
+      DO 60 J = 2, N
+         IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            IDXP( K2 ) = J
+            IF( J.EQ.N )
+     $         GO TO 100
+         ELSE
+            JPREV = J
+            GO TO 70
+         END IF
+   60 CONTINUE
+   70 CONTINUE
+      J = JPREV
+   80 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 90
+      IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         IDXP( K2 ) = J
+      ELSE
+*
+*        Check if singular values are close enough to allow deflation.
+*
+         IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            S = Z( JPREV )
+            C = Z( J )
+*
+*           Find sqrt(a**2+b**2) without overflow or
+*           destructive underflow.
+*
+            TAU = DLAPY2( C, S )
+            Z( J ) = TAU
+            Z( JPREV ) = ZERO
+            C = C / TAU
+            S = -S / TAU
+*
+*           Record the appropriate Givens rotation
+*
+            IF( ICOMPQ.EQ.1 ) THEN
+               GIVPTR = GIVPTR + 1
+               IDXJP = IDXQ( IDX( JPREV )+1 )
+               IDXJ = IDXQ( IDX( J )+1 )
+               IF( IDXJP.LE.NLP1 ) THEN
+                  IDXJP = IDXJP - 1
+               END IF
+               IF( IDXJ.LE.NLP1 ) THEN
+                  IDXJ = IDXJ - 1
+               END IF
+               GIVCOL( GIVPTR, 2 ) = IDXJP
+               GIVCOL( GIVPTR, 1 ) = IDXJ
+               GIVNUM( GIVPTR, 2 ) = C
+               GIVNUM( GIVPTR, 1 ) = S
+            END IF
+            CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
+            CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
+            K2 = K2 - 1
+            IDXP( K2 ) = JPREV
+            JPREV = J
+         ELSE
+            K = K + 1
+            ZW( K ) = Z( JPREV )
+            DSIGMA( K ) = D( JPREV )
+            IDXP( K ) = JPREV
+            JPREV = J
+         END IF
+      END IF
+      GO TO 80
+   90 CONTINUE
+*
+*     Record the last singular value.
+*
+      K = K + 1
+      ZW( K ) = Z( JPREV )
+      DSIGMA( K ) = D( JPREV )
+      IDXP( K ) = JPREV
+*
+  100 CONTINUE
+*
+*     Sort the singular values into DSIGMA. The singular values which
+*     were not deflated go into the first K slots of DSIGMA, except
+*     that DSIGMA(1) is treated separately.
+*
+      DO 110 J = 2, N
+         JP = IDXP( J )
+         DSIGMA( J ) = D( JP )
+         VFW( J ) = VF( JP )
+         VLW( J ) = VL( JP )
+  110 CONTINUE
+      IF( ICOMPQ.EQ.1 ) THEN
+         DO 120 J = 2, N
+            JP = IDXP( J )
+            PERM( J ) = IDXQ( IDX( JP )+1 )
+            IF( PERM( J ).LE.NLP1 ) THEN
+               PERM( J ) = PERM( J ) - 1
+            END IF
+  120    CONTINUE
+      END IF
+*
+*     The deflated singular values go back into the last N - K slots of
+*     D.
+*
+      CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+*
+*     Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
+*     VL(M).
+*
+      DSIGMA( 1 ) = ZERO
+      HLFTOL = TOL / TWO
+      IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+     $   DSIGMA( 2 ) = HLFTOL
+      IF( M.GT.N ) THEN
+         Z( 1 ) = DLAPY2( Z1, Z( M ) )
+         IF( Z( 1 ).LE.TOL ) THEN
+            C = ONE
+            S = ZERO
+            Z( 1 ) = TOL
+         ELSE
+            C = Z1 / Z( 1 )
+            S = -Z( M ) / Z( 1 )
+         END IF
+         CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
+         CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
+      ELSE
+         IF( ABS( Z1 ).LE.TOL ) THEN
+            Z( 1 ) = TOL
+         ELSE
+            Z( 1 ) = Z1
+         END IF
+      END IF
+*
+*     Restore Z, VF, and VL.
+*
+      CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
+      CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
+      CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
+*
+      RETURN
+*
+*     End of DLASD7
+*
+      END
diff --git a/SRC/dlasd8.f b/SRC/dlasd8.f
new file mode 100644
index 00000000..4121519d
--- /dev/null
+++ b/SRC/dlasd8.f
@@ -0,0 +1,253 @@
+      SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
+     $                   DSIGMA, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, K, LDDIFR
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( LDDIFR, * ),
+     $                   DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
+     $                   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASD8 finds the square roots of the roots of the secular equation,
+*  as defined by the values in DSIGMA and Z. It makes the appropriate
+*  calls to DLASD4, and stores, for each  element in D, the distance
+*  to its two nearest poles (elements in DSIGMA). It also updates
+*  the arrays VF and VL, the first and last components of all the
+*  right singular vectors of the original bidiagonal matrix.
+*
+*  DLASD8 is called from DLASD6.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          Specifies whether singular vectors are to be computed in
+*          factored form in the calling routine:
+*          = 0: Compute singular values only.
+*          = 1: Compute singular vectors in factored form as well.
+*
+*  K       (input) INTEGER
+*          The number of terms in the rational function to be solved
+*          by DLASD4.  K >= 1.
+*
+*  D       (output) DOUBLE PRECISION array, dimension ( K )
+*          On output, D contains the updated singular values.
+*
+*  Z       (input) DOUBLE PRECISION array, dimension ( K )
+*          The first K elements of this array contain the components
+*          of the deflation-adjusted updating row vector.
+*
+*  VF      (input/output) DOUBLE PRECISION array, dimension ( K )
+*          On entry, VF contains  information passed through DBEDE8.
+*          On exit, VF contains the first K components of the first
+*          components of all right singular vectors of the bidiagonal
+*          matrix.
+*
+*  VL      (input/output) DOUBLE PRECISION array, dimension ( K )
+*          On entry, VL contains  information passed through DBEDE8.
+*          On exit, VL contains the first K components of the last
+*          components of all right singular vectors of the bidiagonal
+*          matrix.
+*
+*  DIFL    (output) DOUBLE PRECISION array, dimension ( K )
+*          On exit, DIFL(I) = D(I) - DSIGMA(I).
+*
+*  DIFR    (output) DOUBLE PRECISION array,
+*                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
+*                   dimension ( K ) if ICOMPQ = 0.
+*          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
+*          defined and will not be referenced.
+*
+*          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+*          normalizing factors for the right singular vector matrix.
+*
+*  LDDIFR  (input) INTEGER
+*          The leading dimension of DIFR, must be at least K.
+*
+*  DSIGMA  (input) DOUBLE PRECISION array, dimension ( K )
+*          The first K elements of this array contain the old roots
+*          of the deflated updating problem.  These are the poles
+*          of the secular equation.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension at least 3 * K
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
+      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLASCL, DLASD4, DLASET, XERBLA
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DDOT, DLAMC3, DNRM2
+      EXTERNAL           DDOT, DLAMC3, DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( K.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( LDDIFR.LT.K ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASD8', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.1 ) THEN
+         D( 1 ) = ABS( Z( 1 ) )
+         DIFL( 1 ) = D( 1 )
+         IF( ICOMPQ.EQ.1 ) THEN
+            DIFL( 2 ) = ONE
+            DIFR( 1, 2 ) = ONE
+         END IF
+         RETURN
+      END IF
+*
+*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DSIGMA(I) if it is 1; this makes the subsequent
+*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DSIGMA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DSIGMA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DSIGMA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 10 I = 1, K
+         DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+   10 CONTINUE
+*
+*     Book keeping.
+*
+      IWK1 = 1
+      IWK2 = IWK1 + K
+      IWK3 = IWK2 + K
+      IWK2I = IWK2 - 1
+      IWK3I = IWK3 - 1
+*
+*     Normalize Z.
+*
+      RHO = DNRM2( K, Z, 1 )
+      CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+      RHO = RHO*RHO
+*
+*     Initialize WORK(IWK3).
+*
+      CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
+*
+*     Compute the updated singular values, the arrays DIFL, DIFR,
+*     and the updated Z.
+*
+      DO 40 J = 1, K
+         CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
+     $                WORK( IWK2 ), INFO )
+*
+*        If the root finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
+         DIFL( J ) = -WORK( J )
+         DIFR( J, 1 ) = -WORK( J+1 )
+         DO 20 I = 1, J - 1
+            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+     $                        WORK( IWK2I+I ) / ( DSIGMA( I )-
+     $                        DSIGMA( J ) ) / ( DSIGMA( I )+
+     $                        DSIGMA( J ) )
+   20    CONTINUE
+         DO 30 I = J + 1, K
+            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+     $                        WORK( IWK2I+I ) / ( DSIGMA( I )-
+     $                        DSIGMA( J ) ) / ( DSIGMA( I )+
+     $                        DSIGMA( J ) )
+   30    CONTINUE
+   40 CONTINUE
+*
+*     Compute updated Z.
+*
+      DO 50 I = 1, K
+         Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
+   50 CONTINUE
+*
+*     Update VF and VL.
+*
+      DO 80 J = 1, K
+         DIFLJ = DIFL( J )
+         DJ = D( J )
+         DSIGJ = -DSIGMA( J )
+         IF( J.LT.K ) THEN
+            DIFRJ = -DIFR( J, 1 )
+            DSIGJP = -DSIGMA( J+1 )
+         END IF
+         WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
+         DO 60 I = 1, J - 1
+            WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
+     $                   / ( DSIGMA( I )+DJ )
+   60    CONTINUE
+         DO 70 I = J + 1, K
+            WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
+     $                   / ( DSIGMA( I )+DJ )
+   70    CONTINUE
+         TEMP = DNRM2( K, WORK, 1 )
+         WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
+         WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
+         IF( ICOMPQ.EQ.1 ) THEN
+            DIFR( J, 2 ) = TEMP
+         END IF
+   80 CONTINUE
+*
+      CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
+      CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
+*
+      RETURN
+*
+*     End of DLASD8
+*
+      END
diff --git a/SRC/dlasda.f b/SRC/dlasda.f
new file mode 100644
index 00000000..fe8f33ec
--- /dev/null
+++ b/SRC/dlasda.f
@@ -0,0 +1,390 @@
+      SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
+     $                   DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
+     $                   PERM, GIVNUM, C, S, WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+     $                   K( * ), PERM( LDGCOL, * )
+      DOUBLE PRECISION   C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
+     $                   E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
+     $                   S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
+     $                   Z( LDU, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Using a divide and conquer approach, DLASDA computes the singular
+*  value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
+*  B with diagonal D and offdiagonal E, where M = N + SQRE. The
+*  algorithm computes the singular values in the SVD B = U * S * VT.
+*  The orthogonal matrices U and VT are optionally computed in
+*  compact form.
+*
+*  A related subroutine, DLASD0, computes the singular values and
+*  the singular vectors in explicit form.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed
+*         in compact form, as follows
+*         = 0: Compute singular values only.
+*         = 1: Compute singular vectors of upper bidiagonal
+*              matrix in compact form.
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The row dimension of the upper bidiagonal matrix. This is
+*         also the dimension of the main diagonal array D.
+*
+*  SQRE   (input) INTEGER
+*         Specifies the column dimension of the bidiagonal matrix.
+*         = 0: The bidiagonal matrix has column dimension M = N;
+*         = 1: The bidiagonal matrix has column dimension M = N + 1.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension ( N )
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix. On exit D, if INFO = 0, contains its singular values.
+*
+*  E      (input) DOUBLE PRECISION array, dimension ( M-1 )
+*         Contains the subdiagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  U      (output) DOUBLE PRECISION array,
+*         dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
+*         singular vector matrices of all subproblems at the bottom
+*         level.
+*
+*  LDU    (input) INTEGER, LDU = > N.
+*         The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
+*         GIVNUM, and Z.
+*
+*  VT     (output) DOUBLE PRECISION array,
+*         dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
+*         singular vector matrices of all subproblems at the bottom
+*         level.
+*
+*  K      (output) INTEGER array,
+*         dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
+*         If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
+*         secular equation on the computation tree.
+*
+*  DIFL   (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
+*         where NLVL = floor(log_2 (N/SMLSIZ))).
+*
+*  DIFR   (output) DOUBLE PRECISION array,
+*                  dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
+*                  dimension ( N ) if ICOMPQ = 0.
+*         If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
+*         record distances between singular values on the I-th
+*         level and singular values on the (I -1)-th level, and
+*         DIFR(1:N, 2 * I ) contains the normalizing factors for
+*         the right singular vector matrix. See DLASD8 for details.
+*
+*  Z      (output) DOUBLE PRECISION array,
+*                  dimension ( LDU, NLVL ) if ICOMPQ = 1 and
+*                  dimension ( N ) if ICOMPQ = 0.
+*         The first K elements of Z(1, I) contain the components of
+*         the deflation-adjusted updating row vector for subproblems
+*         on the I-th level.
+*
+*  POLES  (output) DOUBLE PRECISION array,
+*         dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
+*         POLES(1, 2*I) contain  the new and old singular values
+*         involved in the secular equations on the I-th level.
+*
+*  GIVPTR (output) INTEGER array,
+*         dimension ( N ) if ICOMPQ = 1, and not referenced if
+*         ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
+*         the number of Givens rotations performed on the I-th
+*         problem on the computation tree.
+*
+*  GIVCOL (output) INTEGER array,
+*         dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
+*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+*         GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
+*         of Givens rotations performed on the I-th level on the
+*         computation tree.
+*
+*  LDGCOL (input) INTEGER, LDGCOL = > N.
+*         The leading dimension of arrays GIVCOL and PERM.
+*
+*  PERM   (output) INTEGER array,
+*         dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
+*         permutations done on the I-th level of the computation tree.
+*
+*  GIVNUM (output) DOUBLE PRECISION array,
+*         dimension ( LDU,  2 * NLVL ) if ICOMPQ = 1, and not
+*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+*         GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
+*         values of Givens rotations performed on the I-th level on
+*         the computation tree.
+*
+*  C      (output) DOUBLE PRECISION array,
+*         dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
+*         If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
+*         C( I ) contains the C-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  S      (output) DOUBLE PRECISION array, dimension ( N ) if
+*         ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
+*         and the I-th subproblem is not square, on exit, S( I )
+*         contains the S-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  WORK   (workspace) DOUBLE PRECISION array, dimension
+*         (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
+*
+*  IWORK  (workspace) INTEGER array.
+*         Dimension must be at least (7 * N).
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
+     $                   J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
+     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
+     $                   NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      ELSE IF( LDU.LT.( N+SQRE ) ) THEN
+         INFO = -8
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -17
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASDA', -INFO )
+         RETURN
+      END IF
+*
+      M = N + SQRE
+*
+*     If the input matrix is too small, call DLASDQ to find the SVD.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
+     $                   U, LDU, WORK, INFO )
+         ELSE
+            CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
+     $                   U, LDU, WORK, INFO )
+         END IF
+         RETURN
+      END IF
+*
+*     Book-keeping and  set up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+      IDXQ = NDIMR + N
+      IWK = IDXQ + N
+*
+      NCC = 0
+      NRU = 0
+*
+      SMLSZP = SMLSIZ + 1
+      VF = 1
+      VL = VF + M
+      NWORK1 = VL + M
+      NWORK2 = NWORK1 + SMLSZP*SMLSZP
+*
+      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     for the nodes on bottom level of the tree, solve
+*     their subproblems by DLASDQ.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 30 I = NDB1, ND
+*
+*        IC : center row of each node
+*        NL : number of rows of left  subproblem
+*        NR : number of rows of right subproblem
+*        NLF: starting row of the left   subproblem
+*        NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NLP1 = NL + 1
+         NR = IWORK( NDIMR+I1 )
+         NLF = IC - NL
+         NRF = IC + 1
+         IDXQI = IDXQ + NLF - 2
+         VFI = VF + NLF - 1
+         VLI = VL + NLF - 1
+         SQREI = 1
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
+     $                   SMLSZP )
+            CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
+     $                   E( NLF ), WORK( NWORK1 ), SMLSZP,
+     $                   WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
+     $                   WORK( NWORK2 ), INFO )
+            ITEMP = NWORK1 + NL*SMLSZP
+            CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+            CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+         ELSE
+            CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
+            CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
+            CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
+     $                   E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
+     $                   U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
+            CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
+            CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
+         END IF
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         DO 10 J = 1, NL
+            IWORK( IDXQI+J ) = J
+   10    CONTINUE
+         IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
+            SQREI = 0
+         ELSE
+            SQREI = 1
+         END IF
+         IDXQI = IDXQI + NLP1
+         VFI = VFI + NLP1
+         VLI = VLI + NLP1
+         NRP1 = NR + SQREI
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
+     $                   SMLSZP )
+            CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
+     $                   E( NRF ), WORK( NWORK1 ), SMLSZP,
+     $                   WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
+     $                   WORK( NWORK2 ), INFO )
+            ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
+            CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+            CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+         ELSE
+            CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
+            CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
+            CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
+     $                   E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
+     $                   U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
+            CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
+            CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
+         END IF
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         DO 20 J = 1, NR
+            IWORK( IDXQI+J ) = J
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Now conquer each subproblem bottom-up.
+*
+      J = 2**NLVL
+      DO 50 LVL = NLVL, 1, -1
+         LVL2 = LVL*2 - 1
+*
+*        Find the first node LF and last node LL on
+*        the current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 40 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            IF( I.EQ.LL ) THEN
+               SQREI = SQRE
+            ELSE
+               SQREI = 1
+            END IF
+            VFI = VF + NLF - 1
+            VLI = VL + NLF - 1
+            IDXQI = IDXQ + NLF - 1
+            ALPHA = D( IC )
+            BETA = E( IC )
+            IF( ICOMPQ.EQ.0 ) THEN
+               CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+     $                      WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+     $                      IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
+     $                      LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
+     $                      K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
+     $                      IWORK( IWK ), INFO )
+            ELSE
+               J = J - 1
+               CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+     $                      WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+     $                      IWORK( IDXQI ), PERM( NLF, LVL ),
+     $                      GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                      GIVNUM( NLF, LVL2 ), LDU,
+     $                      POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
+     $                      DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
+     $                      C( J ), S( J ), WORK( NWORK1 ),
+     $                      IWORK( IWK ), INFO )
+            END IF
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+   40    CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of DLASDA
+*
+      END
diff --git a/SRC/dlasdq.f b/SRC/dlasdq.f
new file mode 100644
index 00000000..08f7e8f8
--- /dev/null
+++ b/SRC/dlasdq.f
@@ -0,0 +1,316 @@
+      SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
+     $                   U, LDU, C, LDC, WORK, INFO )
+*
+*  -- LAPACK auxiliary 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, SQRE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASDQ computes the singular value decomposition (SVD) of a real
+*  (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
+*  E, accumulating the transformations if desired. Letting B denote
+*  the input bidiagonal matrix, the algorithm computes orthogonal
+*  matrices Q and P such that B = Q * S * P' (P' denotes the transpose
+*  of P). The singular values S are overwritten on D.
+*
+*  The input matrix U  is changed to U  * Q  if desired.
+*  The input matrix VT is changed to P' * VT if desired.
+*  The input matrix C  is changed to Q' * C  if desired.
+*
+*  See "Computing  Small Singular Values of Bidiagonal Matrices With
+*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+*  LAPACK Working Note #3, for a detailed description of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO  (input) CHARACTER*1
+*        On entry, UPLO specifies whether the input bidiagonal matrix
+*        is upper or lower bidiagonal, and wether it is square are
+*        not.
+*           UPLO = 'U' or 'u'   B is upper bidiagonal.
+*           UPLO = 'L' or 'l'   B is lower bidiagonal.
+*
+*  SQRE  (input) INTEGER
+*        = 0: then the input matrix is N-by-N.
+*        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
+*             (N+1)-by-N if UPLU = 'L'.
+*
+*        The bidiagonal matrix has
+*        N = NL + NR + 1 rows and
+*        M = N + SQRE >= N columns.
+*
+*  N     (input) INTEGER
+*        On entry, N specifies the number of rows and columns
+*        in the matrix. N must be at least 0.
+*
+*  NCVT  (input) INTEGER
+*        On entry, NCVT specifies the number of columns of
+*        the matrix VT. NCVT must be at least 0.
+*
+*  NRU   (input) INTEGER
+*        On entry, NRU specifies the number of rows of
+*        the matrix U. NRU must be at least 0.
+*
+*  NCC   (input) INTEGER
+*        On entry, NCC specifies the number of columns of
+*        the matrix C. NCC must be at least 0.
+*
+*  D     (input/output) DOUBLE PRECISION array, dimension (N)
+*        On entry, D contains the diagonal entries of the
+*        bidiagonal matrix whose SVD is desired. On normal exit,
+*        D contains the singular values in ascending order.
+*
+*  E     (input/output) DOUBLE PRECISION array.
+*        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
+*        On entry, the entries of E contain the offdiagonal entries
+*        of the bidiagonal matrix whose SVD is desired. On normal
+*        exit, E will contain 0. If the algorithm does not converge,
+*        D and E will contain the diagonal and superdiagonal entries
+*        of a bidiagonal matrix orthogonally equivalent to the one
+*        given as input.
+*
+*  VT    (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
+*        On entry, contains a matrix which on exit has been
+*        premultiplied by P', dimension N-by-NCVT if SQRE = 0
+*        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
+*
+*  LDVT  (input) INTEGER
+*        On entry, LDVT specifies the leading dimension of VT as
+*        declared in the calling (sub) program. LDVT must be at
+*        least 1. If NCVT is nonzero LDVT must also be at least N.
+*
+*  U     (input/output) DOUBLE PRECISION array, dimension (LDU, N)
+*        On entry, contains a  matrix which on exit has been
+*        postmultiplied by Q, dimension NRU-by-N if SQRE = 0
+*        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
+*
+*  LDU   (input) INTEGER
+*        On entry, LDU  specifies the leading dimension of U as
+*        declared in the calling (sub) program. LDU must be at
+*        least max( 1, NRU ) .
+*
+*  C     (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
+*        On entry, contains an N-by-NCC matrix which on exit
+*        has been premultiplied by Q'  dimension N-by-NCC if SQRE = 0
+*        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
+*
+*  LDC   (input) INTEGER
+*        On entry, LDC  specifies the leading dimension of C as
+*        declared in the calling (sub) program. LDC must be at
+*        least 1. If NCC is nonzero, LDC must also be at least N.
+*
+*  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)
+*        Workspace. Only referenced if one of NCVT, NRU, or NCC is
+*        nonzero, and if N is at least 2.
+*
+*  INFO  (output) INTEGER
+*        On exit, a value of 0 indicates a successful exit.
+*        If INFO < 0, argument number -INFO is illegal.
+*        If INFO > 0, the algorithm did not converge, and INFO
+*        specifies how many superdiagonals did not converge.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ROTATE
+      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
+      DOUBLE PRECISION   CS, R, SMIN, SN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSQR, DLARTG, DLASR, DSWAP, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IUPLO = 0
+      IF( LSAME( UPLO, 'U' ) )
+     $   IUPLO = 1
+      IF( LSAME( UPLO, 'L' ) )
+     $   IUPLO = 2
+      IF( IUPLO.EQ.0 ) THEN
+         INFO = -1
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NCVT.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRU.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+         INFO = -10
+      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+         INFO = -12
+      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASDQ', -INFO )
+         RETURN
+      END IF
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     ROTATE is true if any singular vectors desired, false otherwise
+*
+      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+      NP1 = N + 1
+      SQRE1 = SQRE
+*
+*     If matrix non-square upper bidiagonal, rotate to be lower
+*     bidiagonal.  The rotations are on the right.
+*
+      IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
+         DO 10 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( ROTATE ) THEN
+               WORK( I ) = CS
+               WORK( N+I ) = SN
+            END IF
+   10    CONTINUE
+         CALL DLARTG( D( N ), E( N ), CS, SN, R )
+         D( N ) = R
+         E( N ) = ZERO
+         IF( ROTATE ) THEN
+            WORK( N ) = CS
+            WORK( N+N ) = SN
+         END IF
+         IUPLO = 2
+         SQRE1 = 0
+*
+*        Update singular vectors if desired.
+*
+         IF( NCVT.GT.0 )
+     $      CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
+     $                  WORK( NP1 ), VT, LDVT )
+      END IF
+*
+*     If matrix lower bidiagonal, rotate to be upper bidiagonal
+*     by applying Givens rotations on the left.
+*
+      IF( IUPLO.EQ.2 ) THEN
+         DO 20 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( ROTATE ) THEN
+               WORK( I ) = CS
+               WORK( N+I ) = SN
+            END IF
+   20    CONTINUE
+*
+*        If matrix (N+1)-by-N lower bidiagonal, one additional
+*        rotation is needed.
+*
+         IF( SQRE1.EQ.1 ) THEN
+            CALL DLARTG( D( N ), E( N ), CS, SN, R )
+            D( N ) = R
+            IF( ROTATE ) THEN
+               WORK( N ) = CS
+               WORK( N+N ) = SN
+            END IF
+         END IF
+*
+*        Update singular vectors if desired.
+*
+         IF( NRU.GT.0 ) THEN
+            IF( SQRE1.EQ.0 ) THEN
+               CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
+     $                     WORK( NP1 ), U, LDU )
+            ELSE
+               CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
+     $                     WORK( NP1 ), U, LDU )
+            END IF
+         END IF
+         IF( NCC.GT.0 ) THEN
+            IF( SQRE1.EQ.0 ) THEN
+               CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
+     $                     WORK( NP1 ), C, LDC )
+            ELSE
+               CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
+     $                     WORK( NP1 ), C, LDC )
+            END IF
+         END IF
+      END IF
+*
+*     Call DBDSQR to compute the SVD of the reduced real
+*     N-by-N upper bidiagonal matrix.
+*
+      CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
+     $             LDC, WORK, INFO )
+*
+*     Sort the singular values into ascending order (insertion sort on
+*     singular values, but only one transposition per singular vector)
+*
+      DO 40 I = 1, N
+*
+*        Scan for smallest D(I).
+*
+         ISUB = I
+         SMIN = D( I )
+         DO 30 J = I + 1, N
+            IF( D( J ).LT.SMIN ) THEN
+               ISUB = J
+               SMIN = D( J )
+            END IF
+   30    CONTINUE
+         IF( ISUB.NE.I ) THEN
+*
+*           Swap singular values and vectors.
+*
+            D( ISUB ) = D( I )
+            D( I ) = SMIN
+            IF( NCVT.GT.0 )
+     $         CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
+         END IF
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of DLASDQ
+*
+      END
diff --git a/SRC/dlasdt.f b/SRC/dlasdt.f
new file mode 100644
index 00000000..b2b8eee6
--- /dev/null
+++ b/SRC/dlasdt.f
@@ -0,0 +1,105 @@
+      SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LVL, MSUB, N, ND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            INODE( * ), NDIML( * ), NDIMR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASDT creates a tree of subproblems for bidiagonal divide and
+*  conquer.
+*
+*  Arguments
+*  =========
+*
+*   N      (input) INTEGER
+*          On entry, the number of diagonal elements of the
+*          bidiagonal matrix.
+*
+*   LVL    (output) INTEGER
+*          On exit, the number of levels on the computation tree.
+*
+*   ND     (output) INTEGER
+*          On exit, the number of nodes on the tree.
+*
+*   INODE  (output) INTEGER array, dimension ( N )
+*          On exit, centers of subproblems.
+*
+*   NDIML  (output) INTEGER array, dimension ( N )
+*          On exit, row dimensions of left children.
+*
+*   NDIMR  (output) INTEGER array, dimension ( N )
+*          On exit, row dimensions of right children.
+*
+*   MSUB   (input) INTEGER.
+*          On entry, the maximum row dimension each subproblem at the
+*          bottom of the tree can be of.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IL, IR, LLST, MAXN, NCRNT, NLVL
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, INT, LOG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Find the number of levels on the tree.
+*
+      MAXN = MAX( 1, N )
+      TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO )
+      LVL = INT( TEMP ) + 1
+*
+      I = N / 2
+      INODE( 1 ) = I + 1
+      NDIML( 1 ) = I
+      NDIMR( 1 ) = N - I - 1
+      IL = 0
+      IR = 1
+      LLST = 1
+      DO 20 NLVL = 1, LVL - 1
+*
+*        Constructing the tree at (NLVL+1)-st level. The number of
+*        nodes created on this level is LLST * 2.
+*
+         DO 10 I = 0, LLST - 1
+            IL = IL + 2
+            IR = IR + 2
+            NCRNT = LLST + I
+            NDIML( IL ) = NDIML( NCRNT ) / 2
+            NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
+            INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
+            NDIML( IR ) = NDIMR( NCRNT ) / 2
+            NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
+            INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
+   10    CONTINUE
+         LLST = LLST*2
+   20 CONTINUE
+      ND = LLST*2 - 1
+*
+      RETURN
+*
+*     End of DLASDT
+*
+      END
diff --git a/SRC/dlaset.f b/SRC/dlaset.f
new file mode 100644
index 00000000..fc7bc2f5
--- /dev/null
+++ b/SRC/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/dlasq1.f b/SRC/dlasq1.f
new file mode 100644
index 00000000..6f4c3413
--- /dev/null
+++ b/SRC/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/dlasq2.f b/SRC/dlasq2.f
new file mode 100644
index 00000000..b6b79aeb
--- /dev/null
+++ b/SRC/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/dlasq3.f b/SRC/dlasq3.f
new file mode 100644
index 00000000..ce4055d8
--- /dev/null
+++ b/SRC/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/dlasq4.f b/SRC/dlasq4.f
new file mode 100644
index 00000000..db2b6fe5
--- /dev/null
+++ b/SRC/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/dlasq5.f b/SRC/dlasq5.f
new file mode 100644
index 00000000..a006c99e
--- /dev/null
+++ b/SRC/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/dlasq6.f b/SRC/dlasq6.f
new file mode 100644
index 00000000..e7eb7d0a
--- /dev/null
+++ b/SRC/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/dlasr.f b/SRC/dlasr.f
new file mode 100644
index 00000000..7e54bfc7
--- /dev/null
+++ b/SRC/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/dlasrt.f b/SRC/dlasrt.f
new file mode 100644
index 00000000..37e02178
--- /dev/null
+++ b/SRC/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/dlassq.f b/SRC/dlassq.f
new file mode 100644
index 00000000..217e794d
--- /dev/null
+++ b/SRC/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/dlasv2.f b/SRC/dlasv2.f
new file mode 100644
index 00000000..4a00b25d
--- /dev/null
+++ b/SRC/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/dlaswp.f b/SRC/dlaswp.f
new file mode 100644
index 00000000..a11a87e9
--- /dev/null
+++ b/SRC/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/dlasy2.f b/SRC/dlasy2.f
new file mode 100644
index 00000000..3ff12070
--- /dev/null
+++ b/SRC/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/dlasyf.f b/SRC/dlasyf.f
new file mode 100644
index 00000000..67b9c147
--- /dev/null
+++ b/SRC/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/dlatbs.f b/SRC/dlatbs.f
new file mode 100644
index 00000000..48d8c2e1
--- /dev/null
+++ b/SRC/dlatbs.f
@@ -0,0 +1,723 @@
+      SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, 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, KD, LDAB, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), CNORM( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLATBS solves one of the triangular systems
+*
+*     A *x = s*b  or  A'*x = s*b
+*
+*  with scaling to prevent overflow, where A is an upper or lower
+*  triangular band matrix.  Here 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 DTBSV is called.  If the matrix A
+*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a
+*  non-trivial solution to A*x = 0 is returned.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of subdiagonals or superdiagonals in the
+*          triangular matrix A.  KD >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first KD+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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, DTBSV
+*  is called, otherwise, specific code is used which checks for possible
+*  overflow or divide-by-zero at every operation.
+*
+*  A columnwise scheme is used for solving A*x = b.  The basic algorithm
+*  if A is lower triangular is
+*
+*       x[1:n] := b[1:n]
+*       for j = 1, ..., n
+*            x(j) := x(j) / A(j,j)
+*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+*       end
+*
+*  Define bounds on the components of x after j iterations of the loop:
+*     M(j) = bound on x[1:j]
+*     G(j) = bound on x[j+1:n]
+*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+*  Then for iteration j+1 we have
+*     M(j+1) <= G(j) / | A(j+1,j+1) |
+*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+*  where CNORM(j+1) is greater than or equal to the infinity-norm of
+*  column j+1 of A, not counting the diagonal.  Hence
+*
+*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+*                  1<=i<=j
+*  and
+*
+*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+*                                   1<=i< j
+*
+*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the
+*  reciprocal of the largest M(j), j=1,..,n, is larger than
+*  max(underflow, 1/overflow).
+*
+*  The bound on x(j) is also used to determine when a step in the
+*  columnwise method can be performed without fear of overflow.  If
+*  the computed bound is greater than a large constant, x is scaled to
+*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+*  Similarly, a row-wise scheme is used to solve A'*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 DTBSV 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, JLEN, MAIND
+      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, DTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLATBS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            DO 10 J = 1, N
+               JLEN = MIN( KD, J-1 )
+               CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N
+               JLEN = MIN( KD, N-J )
+               IF( JLEN.GT.0 ) THEN
+                  CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 )
+               ELSE
+                  CNORM( J ) = ZERO
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM.
+*
+      IMAX = IDAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = ONE / ( SMLNUM*TMAX )
+         CALL DSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine DTBSV can be used.
+*
+      J = IDAMAX( N, X, 1 )
+      XMAX = ABS( X( J ) )
+      XBND = XMAX
+      IF( NOTRAN ) THEN
+*
+*        Compute the growth in A * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+            MAIND = KD + 1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+            MAIND = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 50
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 30 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              M(j) = G(j-1) / abs(A(j,j))
+*
+               TJJ = ABS( AB( MAIND, J ) )
+               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+               ELSE
+*
+*                 G(j) could overflow, set GROW to 0.
+*
+                  GROW = ZERO
+               END IF
+   30       CONTINUE
+            GROW = XBND
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+   40       CONTINUE
+         END IF
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute the growth in A' * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+            MAIND = KD + 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+            MAIND = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 80
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, M(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 60 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+               XJ = ONE + CNORM( J )
+               GROW = MIN( GROW, XBND / XJ )
+*
+*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+               TJJ = ABS( AB( MAIND, J ) )
+               IF( XJ.GT.TJJ )
+     $            XBND = XBND*( TJJ / XJ )
+   60       CONTINUE
+            GROW = MIN( GROW, XBND )
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 70 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+               XJ = ONE + CNORM( J )
+               GROW = GROW / XJ
+   70       CONTINUE
+         END IF
+   80    CONTINUE
+      END IF
+*
+      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+*        Use the Level 2 BLAS solve if the reciprocal of the bound on
+*        elements of X is not too small.
+*
+         CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
+      ELSE
+*
+*        Use a Level 1 BLAS solve, scaling intermediate results.
+*
+         IF( XMAX.GT.BIGNUM ) THEN
+*
+*           Scale X so that its components are less than or equal to
+*           BIGNUM in absolute value.
+*
+            SCALE = BIGNUM / XMAX
+            CALL DSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            DO 110 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = ABS( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = AB( MAIND, J )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 100
+               END IF
+               TJJ = ABS( TJJS )
+               IF( TJJ.GT.SMLNUM ) THEN
+*
+*                    abs(A(j,j)) > SMLNUM:
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by 1/b(j).
+*
+                        REC = ONE / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J ) = X( J ) / TJJS
+                  XJ = ABS( X( J ) )
+               ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                    0 < abs(A(j,j)) <= SMLNUM:
+*
+                  IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+*                       to avoid overflow when dividing by A(j,j).
+*
+                     REC = ( TJJ*BIGNUM ) / XJ
+                     IF( CNORM( J ).GT.ONE ) THEN
+*
+*                          Scale by 1/CNORM(j) to avoid overflow when
+*                          multiplying x(j) times column j.
+*
+                        REC = REC / CNORM( J )
+                     END IF
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+                  X( J ) = X( J ) / TJJS
+                  XJ = ABS( X( J ) )
+               ELSE
+*
+*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                    scale = 0, and compute a solution to A*x = 0.
+*
+                  DO 90 I = 1, N
+                     X( I ) = ZERO
+   90             CONTINUE
+                  X( J ) = ONE
+                  XJ = ONE
+                  SCALE = ZERO
+                  XMAX = ZERO
+               END IF
+  100          CONTINUE
+*
+*              Scale x if necessary to avoid overflow when adding a
+*              multiple of column j of A.
+*
+               IF( XJ.GT.ONE ) THEN
+                  REC = ONE / XJ
+                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+*                    Scale x by 1/(2*abs(x(j))).
+*
+                     REC = REC*HALF
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL DSCAL( N, HALF, X, 1 )
+                  SCALE = SCALE*HALF
+               END IF
+*
+               IF( UPPER ) THEN
+                  IF( J.GT.1 ) THEN
+*
+*                    Compute the update
+*                       x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
+*                                             x(j)* A(max(1,j-kd):j-1,j)
+*
+                     JLEN = MIN( KD, J-1 )
+                     CALL DAXPY( JLEN, -X( J )*TSCAL,
+     $                           AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
+                     I = IDAMAX( J-1, X, 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+               ELSE IF( J.LT.N ) THEN
+*
+*                 Compute the update
+*                    x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
+*                                          x(j) * A(j+1:min(j+kd,n),j)
+*
+                  JLEN = MIN( KD, N-J )
+                  IF( JLEN.GT.0 )
+     $               CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
+     $                           X( J+1 ), 1 )
+                  I = J + IDAMAX( N-J, X( J+1 ), 1 )
+                  XMAX = ABS( X( I ) )
+               END IF
+  110       CONTINUE
+*
+         ELSE
+*
+*           Solve A' * x = b
+*
+            DO 160 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = ABS( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = AB( MAIND, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                  TJJ = ABS( TJJS )
+                  IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                     REC = MIN( ONE, REC*TJJ )
+                     USCAL = USCAL / TJJS
+                  END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               SUMJ = ZERO
+               IF( USCAL.EQ.ONE ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call DDOT to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1,
+     $                      X( J-JLEN ), 1 )
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     IF( JLEN.GT.0 )
+     $                  SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     DO 120 I = 1, JLEN
+                        SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
+     $                         X( J-JLEN-1+I )
+  120                CONTINUE
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     DO 130 I = 1, JLEN
+                        SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
+  130                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.TSCAL ) THEN
+*
+*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - SUMJ
+                  XJ = ABS( X( J ) )
+                  IF( NOUNIT ) THEN
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AB( MAIND, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 150
+                  END IF
+                  TJJ = ABS( TJJS )
+                  IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                     IF( TJJ.LT.ONE ) THEN
+                        IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                           REC = ONE / XJ
+                           CALL DSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = X( J ) / TJJS
+                  ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                       0 < abs(A(j,j)) <= SMLNUM:
+*
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+                        REC = ( TJJ*BIGNUM ) / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = X( J ) / TJJS
+                  ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0, and compute a solution to A'*x = 0.
+*
+                     DO 140 I = 1, N
+                        X( I ) = ZERO
+  140                CONTINUE
+                     X( J ) = ONE
+                     SCALE = ZERO
+                     XMAX = ZERO
+                  END IF
+  150             CONTINUE
+               ELSE
+*
+*                 Compute x(j) := x(j) / A(j,j) - sumj if the dot
+*                 product has already been divided by 1/A(j,j).
+*
+                  X( J ) = X( J ) / TJJS - SUMJ
+               END IF
+               XMAX = MAX( XMAX, ABS( X( J ) ) )
+  160       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of DLATBS
+*
+      END
diff --git a/SRC/dlatdf.f b/SRC/dlatdf.f
new file mode 100644
index 00000000..91fa46e3
--- /dev/null
+++ b/SRC/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/dlatps.f b/SRC/dlatps.f
new file mode 100644
index 00000000..7295e010
--- /dev/null
+++ b/SRC/dlatps.f
@@ -0,0 +1,712 @@
+      SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, 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, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), CNORM( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLATPS solves one of the triangular systems
+*
+*     A *x = s*b  or  A'*x = s*b
+*
+*  with scaling to prevent overflow, where A is an upper or lower
+*  triangular matrix stored in packed form.  Here 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
+*  DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
+*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  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, DTPSV
+*  is called, otherwise, specific code is used which checks for possible
+*  overflow or divide-by-zero at every operation.
+*
+*  A columnwise scheme is used for solving A*x = b.  The basic algorithm
+*  if A is lower triangular is
+*
+*       x[1:n] := b[1:n]
+*       for j = 1, ..., n
+*            x(j) := x(j) / A(j,j)
+*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+*       end
+*
+*  Define bounds on the components of x after j iterations of the loop:
+*     M(j) = bound on x[1:j]
+*     G(j) = bound on x[j+1:n]
+*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+*  Then for iteration j+1 we have
+*     M(j+1) <= G(j) / | A(j+1,j+1) |
+*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+*  where CNORM(j+1) is greater than or equal to the infinity-norm of
+*  column j+1 of A, not counting the diagonal.  Hence
+*
+*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+*                  1<=i<=j
+*  and
+*
+*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+*                                   1<=i< j
+*
+*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the
+*  reciprocal of the largest M(j), j=1,..,n, is larger than
+*  max(underflow, 1/overflow).
+*
+*  The bound on x(j) is also used to determine when a step in the
+*  columnwise method can be performed without fear of overflow.  If
+*  the computed bound is greater than a large constant, x is scaled to
+*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+*  Similarly, a row-wise scheme is used to solve A'*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 DTPSV 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, IP, J, JFIRST, JINC, JLAST, JLEN
+      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLATPS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            IP = 1
+            DO 10 J = 1, N
+               CNORM( J ) = DASUM( J-1, AP( IP ), 1 )
+               IP = IP + J
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            IP = 1
+            DO 20 J = 1, N - 1
+               CNORM( J ) = DASUM( N-J, AP( IP+1 ), 1 )
+               IP = IP + N - J + 1
+   20       CONTINUE
+            CNORM( N ) = ZERO
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM.
+*
+      IMAX = IDAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = ONE / ( SMLNUM*TMAX )
+         CALL DSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine DTPSV can be used.
+*
+      J = IDAMAX( N, X, 1 )
+      XMAX = ABS( X( J ) )
+      XBND = XMAX
+      IF( NOTRAN ) THEN
+*
+*        Compute the growth in A * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 50
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = N
+            DO 30 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              M(j) = G(j-1) / abs(A(j,j))
+*
+               TJJ = ABS( AP( IP ) )
+               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+               ELSE
+*
+*                 G(j) could overflow, set GROW to 0.
+*
+                  GROW = ZERO
+               END IF
+               IP = IP + JINC*JLEN
+               JLEN = JLEN - 1
+   30       CONTINUE
+            GROW = XBND
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+   40       CONTINUE
+         END IF
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute the growth in A' * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 80
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, M(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            DO 60 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+               XJ = ONE + CNORM( J )
+               GROW = MIN( GROW, XBND / XJ )
+*
+*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+               TJJ = ABS( AP( IP ) )
+               IF( XJ.GT.TJJ )
+     $            XBND = XBND*( TJJ / XJ )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+   60       CONTINUE
+            GROW = MIN( GROW, XBND )
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 70 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+               XJ = ONE + CNORM( J )
+               GROW = GROW / XJ
+   70       CONTINUE
+         END IF
+   80    CONTINUE
+      END IF
+*
+      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+*        Use the Level 2 BLAS solve if the reciprocal of the bound on
+*        elements of X is not too small.
+*
+         CALL DTPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
+      ELSE
+*
+*        Use a Level 1 BLAS solve, scaling intermediate results.
+*
+         IF( XMAX.GT.BIGNUM ) THEN
+*
+*           Scale X so that its components are less than or equal to
+*           BIGNUM in absolute value.
+*
+            SCALE = BIGNUM / XMAX
+            CALL DSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            DO 110 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = ABS( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = AP( IP )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 100
+               END IF
+               TJJ = ABS( TJJS )
+               IF( TJJ.GT.SMLNUM ) THEN
+*
+*                    abs(A(j,j)) > SMLNUM:
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by 1/b(j).
+*
+                        REC = ONE / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J ) = X( J ) / TJJS
+                  XJ = ABS( X( J ) )
+               ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                    0 < abs(A(j,j)) <= SMLNUM:
+*
+                  IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+*                       to avoid overflow when dividing by A(j,j).
+*
+                     REC = ( TJJ*BIGNUM ) / XJ
+                     IF( CNORM( J ).GT.ONE ) THEN
+*
+*                          Scale by 1/CNORM(j) to avoid overflow when
+*                          multiplying x(j) times column j.
+*
+                        REC = REC / CNORM( J )
+                     END IF
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+                  X( J ) = X( J ) / TJJS
+                  XJ = ABS( X( J ) )
+               ELSE
+*
+*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                    scale = 0, and compute a solution to A*x = 0.
+*
+                  DO 90 I = 1, N
+                     X( I ) = ZERO
+   90             CONTINUE
+                  X( J ) = ONE
+                  XJ = ONE
+                  SCALE = ZERO
+                  XMAX = ZERO
+               END IF
+  100          CONTINUE
+*
+*              Scale x if necessary to avoid overflow when adding a
+*              multiple of column j of A.
+*
+               IF( XJ.GT.ONE ) THEN
+                  REC = ONE / XJ
+                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+*                    Scale x by 1/(2*abs(x(j))).
+*
+                     REC = REC*HALF
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL DSCAL( N, HALF, X, 1 )
+                  SCALE = SCALE*HALF
+               END IF
+*
+               IF( UPPER ) THEN
+                  IF( J.GT.1 ) THEN
+*
+*                    Compute the update
+*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+                     CALL DAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
+     $                           1 )
+                     I = IDAMAX( J-1, X, 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+                  IP = IP - J
+               ELSE
+                  IF( J.LT.N ) THEN
+*
+*                    Compute the update
+*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+                     CALL DAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + IDAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+                  IP = IP + N - J + 1
+               END IF
+  110       CONTINUE
+*
+         ELSE
+*
+*           Solve A' * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            DO 160 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = ABS( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = AP( IP )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                  TJJ = ABS( TJJS )
+                  IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                     REC = MIN( ONE, REC*TJJ )
+                     USCAL = USCAL / TJJS
+                  END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               SUMJ = ZERO
+               IF( USCAL.EQ.ONE ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call DDOT to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     SUMJ = DDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     SUMJ = DDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 120 I = 1, J - 1
+                        SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
+  120                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 130 I = 1, N - J
+                        SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
+  130                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.TSCAL ) THEN
+*
+*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - SUMJ
+                  XJ = ABS( X( J ) )
+                  IF( NOUNIT ) THEN
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AP( IP )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 150
+                  END IF
+                  TJJ = ABS( TJJS )
+                  IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                     IF( TJJ.LT.ONE ) THEN
+                        IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                           REC = ONE / XJ
+                           CALL DSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = X( J ) / TJJS
+                  ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                       0 < abs(A(j,j)) <= SMLNUM:
+*
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+                        REC = ( TJJ*BIGNUM ) / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = X( J ) / TJJS
+                  ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0, and compute a solution to A'*x = 0.
+*
+                     DO 140 I = 1, N
+                        X( I ) = ZERO
+  140                CONTINUE
+                     X( J ) = ONE
+                     SCALE = ZERO
+                     XMAX = ZERO
+                  END IF
+  150             CONTINUE
+               ELSE
+*
+*                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
+*                 product has already been divided by 1/A(j,j).
+*
+                  X( J ) = X( J ) / TJJS - SUMJ
+               END IF
+               XMAX = MAX( XMAX, ABS( X( J ) ) )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+  160       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of DLATPS
+*
+      END
diff --git a/SRC/dlatrd.f b/SRC/dlatrd.f
new file mode 100644
index 00000000..27bf9b98
--- /dev/null
+++ b/SRC/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/dlatrs.f b/SRC/dlatrs.f
new file mode 100644
index 00000000..bbd3a9e4
--- /dev/null
+++ b/SRC/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/dlatrz.f b/SRC/dlatrz.f
new file mode 100644
index 00000000..9ffd9026
--- /dev/null
+++ b/SRC/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           DLARFP, 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 DLARFP( 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/dlatzm.f b/SRC/dlatzm.f
new file mode 100644
index 00000000..2467ab60
--- /dev/null
+++ b/SRC/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/dlauu2.f b/SRC/dlauu2.f
new file mode 100644
index 00000000..092bdda1
--- /dev/null
+++ b/SRC/dlauu2.f
@@ -0,0 +1,135 @@
+      SUBROUTINE DLAUU2( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAUU2 computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the unblocked form of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAUU2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the product U * U'.
+*
+         DO 10 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
+               CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
+            ELSE
+               CALL DSCAL( I, AII, A( 1, I ), 1 )
+            END IF
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product L' * L.
+*
+         DO 20 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
+               CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+     $                     A( I+1, I ), 1, AII, A( I, 1 ), LDA )
+            ELSE
+               CALL DSCAL( I, AII, A( I, 1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DLAUU2
+*
+      END
diff --git a/SRC/dlauum.f b/SRC/dlauum.f
new file mode 100644
index 00000000..4857c522
--- /dev/null
+++ b/SRC/dlauum.f
@@ -0,0 +1,155 @@
+      SUBROUTINE DLAUUM( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAUUM computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the blocked form of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLAUUM', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL DLAUU2( UPLO, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( UPPER ) THEN
+*
+*           Compute the product U * U'.
+*
+            DO 10 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
+     $                     I-1, IB, ONE, A( I, I ), LDA, A( 1, I ),
+     $                     LDA )
+               CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL DGEMM( 'No transpose', 'Transpose', I-1, IB,
+     $                        N-I-IB+1, ONE, A( 1, I+IB ), LDA,
+     $                        A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
+                  CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1,
+     $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
+     $                        LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute the product L' * L.
+*
+            DO 20 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB,
+     $                     I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
+               CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL DGEMM( 'Transpose', 'No transpose', IB, I-1,
+     $                        N-I-IB+1, ONE, A( I+IB, I ), LDA,
+     $                        A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
+                  CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE,
+     $                        A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLAUUM
+*
+      END
diff --git a/SRC/dlazq3.f b/SRC/dlazq3.f
new file mode 100644
index 00000000..784248f7
--- /dev/null
+++ b/SRC/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/dlazq4.f b/SRC/dlazq4.f
new file mode 100644
index 00000000..7c257f8d
--- /dev/null
+++ b/SRC/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/dopgtr.f b/SRC/dopgtr.f
new file mode 100644
index 00000000..cf0901ff
--- /dev/null
+++ b/SRC/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/dopmtr.f b/SRC/dopmtr.f
new file mode 100644
index 00000000..b926594d
--- /dev/null
+++ b/SRC/dopmtr.f
@@ -0,0 +1,257 @@
+      SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, 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, UPLO
+      INTEGER            INFO, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DOPMTR overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by DSPTRD using packed
+*  storage:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  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.
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension
+*                               (M*(M+1)/2) if SIDE = 'L'
+*                               (N*(N+1)/2) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by DSPTRD.  AP is modified by the routine but
+*          restored on exit.
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'
+*                                     or (N-1) if SIDE = 'R'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DSPTRD.
+*
+*  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) 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            FORWRD, LEFT, NOTRAN, UPPER
+      INTEGER            I, I1, I2, I3, IC, II, JC, MI, NI, NQ
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DOPMTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to DSPTRD with UPLO = 'U'
+*
+         FORWRD = ( LEFT .AND. NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. .NOT.NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+         ELSE
+            MI = M
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IF( LEFT ) THEN
+*
+*              H(i) is applied to C(1:i,1:n)
+*
+               MI = I
+            ELSE
+*
+*              H(i) is applied to C(1:m,1:i)
+*
+               NI = I
+            END IF
+*
+*           Apply H(i)
+*
+            AII = AP( II )
+            AP( II ) = ONE
+            CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
+     $                  WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + I + 2
+            ELSE
+               II = II - I - 1
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Q was determined by a call to DSPTRD with UPLO = 'L'.
+*
+         FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         DO 20 I = I1, I2, I3
+            AII = AP( II )
+            AP( II ) = ONE
+            IF( LEFT ) THEN
+*
+*              H(i) is applied to C(i+1:m,1:n)
+*
+               MI = M - I
+               IC = I + 1
+            ELSE
+*
+*              H(i) is applied to C(1:m,i+1:n)
+*
+               NI = N - I
+               JC = I + 1
+            END IF
+*
+*           Apply H(i)
+*
+            CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
+     $                  C( IC, JC ), LDC, WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + NQ - I + 1
+            ELSE
+               II = II - NQ + I - 2
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DOPMTR
+*
+      END
diff --git a/SRC/dorg2l.f b/SRC/dorg2l.f
new file mode 100644
index 00000000..a20965fd
--- /dev/null
+++ b/SRC/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/dorg2r.f b/SRC/dorg2r.f
new file mode 100644
index 00000000..476e9f70
--- /dev/null
+++ b/SRC/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/dorgbr.f b/SRC/dorgbr.f
new file mode 100644
index 00000000..dc882990
--- /dev/null
+++ b/SRC/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/dorghr.f b/SRC/dorghr.f
new file mode 100644
index 00000000..1283aece
--- /dev/null
+++ b/SRC/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/dorgl2.f b/SRC/dorgl2.f
new file mode 100644
index 00000000..1e08344d
--- /dev/null
+++ b/SRC/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/dorglq.f b/SRC/dorglq.f
new file mode 100644
index 00000000..e4f58c96
--- /dev/null
+++ b/SRC/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/dorgql.f b/SRC/dorgql.f
new file mode 100644
index 00000000..1c4896e9
--- /dev/null
+++ b/SRC/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/dorgqr.f b/SRC/dorgqr.f
new file mode 100644
index 00000000..4db0ef5a
--- /dev/null
+++ b/SRC/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/dorgr2.f b/SRC/dorgr2.f
new file mode 100644
index 00000000..9da45c5f
--- /dev/null
+++ b/SRC/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/dorgrq.f b/SRC/dorgrq.f
new file mode 100644
index 00000000..11633403
--- /dev/null
+++ b/SRC/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/dorgtr.f b/SRC/dorgtr.f
new file mode 100644
index 00000000..4c72d031
--- /dev/null
+++ b/SRC/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/dorm2l.f b/SRC/dorm2l.f
new file mode 100644
index 00000000..27120075
--- /dev/null
+++ b/SRC/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/dorm2r.f b/SRC/dorm2r.f
new file mode 100644
index 00000000..79c9ef35
--- /dev/null
+++ b/SRC/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/dormbr.f b/SRC/dormbr.f
new file mode 100644
index 00000000..8066b893
--- /dev/null
+++ b/SRC/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/dormhr.f b/SRC/dormhr.f
new file mode 100644
index 00000000..5862538e
--- /dev/null
+++ b/SRC/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/dorml2.f b/SRC/dorml2.f
new file mode 100644
index 00000000..d3941c9a
--- /dev/null
+++ b/SRC/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/dormlq.f b/SRC/dormlq.f
new file mode 100644
index 00000000..f0c68ef2
--- /dev/null
+++ b/SRC/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/dormql.f b/SRC/dormql.f
new file mode 100644
index 00000000..f3370f10
--- /dev/null
+++ b/SRC/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/dormqr.f b/SRC/dormqr.f
new file mode 100644
index 00000000..ee372695
--- /dev/null
+++ b/SRC/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/dormr2.f b/SRC/dormr2.f
new file mode 100644
index 00000000..994552fb
--- /dev/null
+++ b/SRC/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/dormr3.f b/SRC/dormr3.f
new file mode 100644
index 00000000..7bdcb856
--- /dev/null
+++ b/SRC/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/dormrq.f b/SRC/dormrq.f
new file mode 100644
index 00000000..522c1392
--- /dev/null
+++ b/SRC/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/dormrz.f b/SRC/dormrz.f
new file mode 100644
index 00000000..b69d9c63
--- /dev/null
+++ b/SRC/dormrz.f
@@ -0,0 +1,293 @@
+      SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. 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
+         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.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/dormtr.f b/SRC/dormtr.f
new file mode 100644
index 00000000..3fe9db0d
--- /dev/null
+++ b/SRC/dormtr.f
@@ -0,0 +1,222 @@
+      SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, 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, UPLO
+      INTEGER            INFO, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMTR overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by DSYTRD:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangle of A contains elementary reflectors
+*                 from DSYTRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from DSYTRD.
+*
+*  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.
+*
+*  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 DSYTRD.
+*
+*  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 DSYTRD.
+*
+*  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, UPPER
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORMQL, DORMQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( UPPER ) THEN
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
+     $              -1 )
+            ELSE
+               NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
+     $              -1 )
+            END IF
+         ELSE
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
+     $              -1 )
+            ELSE
+               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
+     $              -1 )
+            END IF
+         END IF
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMTR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( LEFT ) THEN
+         MI = M - 1
+         NI = N
+      ELSE
+         MI = M
+         NI = N - 1
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to DSYTRD with UPLO = 'U'
+*
+         CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
+     $                LDC, WORK, LWORK, IINFO )
+      ELSE
+*
+*        Q was determined by a call to DSYTRD with UPLO = 'L'
+*
+         IF( LEFT ) THEN
+            I1 = 2
+            I2 = 1
+         ELSE
+            I1 = 1
+            I2 = 2
+         END IF
+         CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+     $                C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMTR
+*
+      END
diff --git a/SRC/dpbcon.f b/SRC/dpbcon.f
new file mode 100644
index 00000000..ad5fa41b
--- /dev/null
+++ b/SRC/dpbcon.f
@@ -0,0 +1,192 @@
+      SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, 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, KD, LDAB, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite band matrix using the
+*  Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          The 1-norm (or infinity-norm) of the symmetric band 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, DLATBS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+     $                   INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+     $                   INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+     $                   INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+     $                   INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = IDAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL DRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of DPBCON
+*
+      END
diff --git a/SRC/dpbequ.f b/SRC/dpbequ.f
new file mode 100644
index 00000000..cb2016e2
--- /dev/null
+++ b/SRC/dpbequ.f
@@ -0,0 +1,166 @@
+      SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBEQU computes row and column scalings intended to equilibrate a
+*  symmetric positive definite band matrix A and reduce its condition
+*  number (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular of A is stored;
+*          = 'L':  Lower triangular of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB     (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) DOUBLE PRECISION
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, J
+      DOUBLE PRECISION   SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+         J = KD + 1
+      ELSE
+         J = 1
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = AB( J, 1 )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      DO 10 I = 2, N
+         S( I ) = AB( J, I )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of DPBEQU
+*
+      END
diff --git a/SRC/dpbrfs.f b/SRC/dpbrfs.f
new file mode 100644
index 00000000..992fc984
--- /dev/null
+++ b/SRC/dpbrfs.f
@@ -0,0 +1,341 @@
+      SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, 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          UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite
+*  and banded, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T of the band matrix A as computed by
+*          DPBTRF, in the same storage format as A (see AB).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  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 DPBTRS.
+*          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            UPPER
+      INTEGER            COUNT, I, J, K, KASE, L, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DPBTRS, DSBMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( N+1, 2*KD+2 )
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               L = KD + 1 - K
+               DO 40 I = MAX( 1, K-KD ), K - 1
+                  WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+                  S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
+               L = 1 - K
+               DO 60 I = K + 1, MIN( N, K+KD )
+                  WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+                  S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+     $                   INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  120          CONTINUE
+               CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DPBRFS
+*
+      END
diff --git a/SRC/dpbstf.f b/SRC/dpbstf.f
new file mode 100644
index 00000000..b6bf9f38
--- /dev/null
+++ b/SRC/dpbstf.f
@@ -0,0 +1,250 @@
+      SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBSTF computes a split Cholesky factorization of a real
+*  symmetric positive definite band matrix A.
+*
+*  This routine is designed to be used in conjunction with DSBGST.
+*
+*  The factorization has the form  A = S**T*S  where S is a band matrix
+*  of the same bandwidth as A and the following structure:
+*
+*    S = ( U    )
+*        ( M  L )
+*
+*  where U is upper triangular of order m = (n+kd)/2, and L is lower
+*  triangular of order n-m.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first kd+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the factor S from the split Cholesky
+*          factorization A = S**T*S. See Further Details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, the factorization could not be completed,
+*               because the updated element a(i,i) was negative; the
+*               matrix A is not positive definite.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 7, KD = 2:
+*
+*  S = ( s11  s12  s13                     )
+*      (      s22  s23  s24                )
+*      (           s33  s34                )
+*      (                s44                )
+*      (           s53  s54  s55           )
+*      (                s64  s65  s66      )
+*      (                     s75  s76  s77 )
+*
+*  If UPLO = 'U', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53  s64  s75
+*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*
+*  If UPLO = 'L', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*  a21  a32  a43  a54  a65  a76   *   s12  s23  s34  s54  s65  s76   *
+*  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KM, M
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSYR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBSTF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+*     Set the splitting point m.
+*
+      M = ( N+KD ) / 2
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+         DO 10 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( KD+1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th column and update the
+*           the leading submatrix within the band.
+*
+            CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
+            CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
+     $                 AB( KD+1, J-KM ), KLD )
+   10    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+         DO 20 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( KD+1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+         DO 30 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( 1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
+            CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
+     $                 AB( 1, J-KM ), KLD )
+   30    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+         DO 40 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( 1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th column and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
+               CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+   50 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of DPBSTF
+*
+      END
diff --git a/SRC/dpbsv.f b/SRC/dpbsv.f
new file mode 100644
index 00000000..4d1b66b0
--- /dev/null
+++ b/SRC/dpbsv.f
@@ -0,0 +1,151 @@
+      SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**T * U,  if UPLO = 'U', or
+*     A = L * L**T,  if UPLO = 'L',
+*  where U is an upper triangular band matrix, and L is a lower
+*  triangular band matrix, with the same number of superdiagonals or
+*  subdiagonals as A.  The factored form of A is then used to solve the
+*  system of equations A * X = B.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**T*U or A = L*L**T of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPBTRF, DPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of DPBSV
+*
+      END
diff --git a/SRC/dpbsvx.f b/SRC/dpbsvx.f
new file mode 100644
index 00000000..1bc4d649
--- /dev/null
+++ b/SRC/dpbsvx.f
@@ -0,0 +1,422 @@
+      SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), S( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+*  compute the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**T * U,  if UPLO = 'U', or
+*        A = L * L**T,  if UPLO = 'L',
+*     where U is an upper triangular band matrix, and L is a lower
+*     triangular band matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFB contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AB and AFB will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right-hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array, except
+*          if FACT = 'F' and EQUED = 'Y', then A must contain the
+*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A
+*          is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the band matrix
+*          A, in the same storage format as A (see AB).  If EQUED = 'Y',
+*          then AFB is the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the equilibrated
+*          matrix A (see the description of A for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  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 EQUED = 'Y',
+*          B is overwritten by diag(S) * 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 if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  Two-dimensional storage of the symmetric matrix A:
+*
+*     a11  a12  a13
+*          a22  a23  a24
+*               a33  a34  a35
+*                    a44  a45  a46
+*                         a55  a56
+*     (aij=conjg(aji))         a66
+*
+*  Band storage of the upper triangle of A:
+*
+*      *    *   a13  a24  a35  a46
+*      *   a12  a23  a34  a45  a56
+*     a11  a22  a33  a44  a55  a66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*     a11  a22  a33  a44  a55  a66
+*     a21  a32  a43  a54  a65   *
+*     a31  a42  a53  a64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU, UPPER
+      INTEGER            I, INFEQU, J, J1, J2
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSB
+      EXTERNAL           LSAME, DLAMCH, DLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DLAQSB, DPBCON, DPBEQU, DPBRFS,
+     $                   DPBTRF, DPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -9
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -10
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -11
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -13
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -15
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         IF( UPPER ) THEN
+            DO 40 J = 1, N
+               J1 = MAX( J-KD, 1 )
+               CALL DCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
+     $                     AFB( KD+1-J+J1, J ), 1 )
+   40       CONTINUE
+         ELSE
+            DO 50 J = 1, N
+               J2 = MIN( J+KD, N )
+               CALL DCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
+   50       CONTINUE
+         END IF
+*
+         CALL DPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = DLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK,
+     $             INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 70 J = 1, NRHS
+            DO 60 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   60       CONTINUE
+   70    CONTINUE
+         DO 80 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   80    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of DPBSVX
+*
+      END
diff --git a/SRC/dpbtf2.f b/SRC/dpbtf2.f
new file mode 100644
index 00000000..8419f914
--- /dev/null
+++ b/SRC/dpbtf2.f
@@ -0,0 +1,194 @@
+      SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBTF2 computes the Cholesky factorization of a real symmetric
+*  positive definite band 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, U' is the transpose of U, 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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KN
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSYR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         DO 10 J = 1, N
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AB( KD+1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 30
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of row J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Compute the Cholesky factorization A = L*L'.
+*
+         DO 20 J = 1, N
+*
+*           Compute L(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AB( 1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 30
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of column J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
+               CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+   30 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of DPBTF2
+*
+      END
diff --git a/SRC/dpbtrf.f b/SRC/dpbtrf.f
new file mode 100644
index 00000000..1aa19ef2
--- /dev/null
+++ b/SRC/dpbtrf.f
@@ -0,0 +1,364 @@
+      SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBTRF computes the Cholesky factorization of a real symmetric
+*  positive definite band matrix A.
+*
+*  The factorization has the form
+*     A = U**T * U,  if UPLO = 'U', or
+*     A = L  * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**T*U or A = L*L**T of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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 band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  Contributed by
+*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, IB, II, J, JJ, NB
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   WORK( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DPBTF2, DPOTF2, DSYRK, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
+     $    ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment
+*
+      NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 )
+*
+*     The block size must not exceed the semi-bandwidth KD, and must not
+*     exceed the limit set by the size of the local array WORK.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KD ) THEN
+*
+*        Use unblocked code
+*
+         CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Compute the Cholesky factorization of a symmetric band
+*           matrix, given the upper triangle of the matrix in band
+*           storage.
+*
+*           Zero the upper triangle of the work array.
+*
+            DO 20 J = 1, NB
+               DO 10 I = 1, J - 1
+                  WORK( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 70 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11   A12   A13
+*                          A22   A23
+*                                A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A12, A22 and
+*                 A23 are empty if IB = KD. The upper triangle of A13
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A12
+*
+                     CALL DTRSM( 'Left', 'Upper', 'Transpose',
+     $                           'Non-unit', IB, I2, ONE, AB( KD+1, I ),
+     $                           LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
+     $                           AB( KD+1-IB, I+IB ), LDAB-1, ONE,
+     $                           AB( KD+1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the lower triangle of A13 into the work array.
+*
+                     DO 40 JJ = 1, I3
+                        DO 30 II = JJ, IB
+                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
+   30                   CONTINUE
+   40                CONTINUE
+*
+*                    Update A13 (in the work array).
+*
+                     CALL DTRSM( 'Left', 'Upper', 'Transpose',
+     $                           'Non-unit', IB, I3, ONE, AB( KD+1, I ),
+     $                           LDAB-1, WORK, LDWORK )
+*
+*                    Update A23
+*
+                     IF( I2.GT.0 )
+     $                  CALL DGEMM( 'Transpose', 'No Transpose', I2, I3,
+     $                              IB, -ONE, AB( KD+1-IB, I+IB ),
+     $                              LDAB-1, WORK, LDWORK, ONE,
+     $                              AB( 1+IB, I+KD ), LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
+     $                           WORK, LDWORK, ONE, AB( KD+1, I+KD ),
+     $                           LDAB-1 )
+*
+*                    Copy the lower triangle of A13 back into place.
+*
+                     DO 60 JJ = 1, I3
+                        DO 50 II = JJ, IB
+                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
+   50                   CONTINUE
+   60                CONTINUE
+                  END IF
+               END IF
+   70       CONTINUE
+         ELSE
+*
+*           Compute the Cholesky factorization of a symmetric band
+*           matrix, given the lower triangle of the matrix in band
+*           storage.
+*
+*           Zero the lower triangle of the work array.
+*
+            DO 90 J = 1, NB
+               DO 80 I = J + 1, NB
+                  WORK( I, J ) = ZERO
+   80          CONTINUE
+   90       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 140 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11
+*                    A21   A22
+*                    A31   A32   A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A21, A22 and
+*                 A32 are empty if IB = KD. The lower triangle of A31
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A21
+*
+                     CALL DTRSM( 'Right', 'Lower', 'Transpose',
+     $                           'Non-unit', I2, IB, ONE, AB( 1, I ),
+     $                           LDAB-1, AB( 1+IB, I ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
+     $                           AB( 1+IB, I ), LDAB-1, ONE,
+     $                           AB( 1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the upper triangle of A31 into the work array.
+*
+                     DO 110 JJ = 1, IB
+                        DO 100 II = 1, MIN( JJ, I3 )
+                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
+  100                   CONTINUE
+  110                CONTINUE
+*
+*                    Update A31 (in the work array).
+*
+                     CALL DTRSM( 'Right', 'Lower', 'Transpose',
+     $                           'Non-unit', I3, IB, ONE, AB( 1, I ),
+     $                           LDAB-1, WORK, LDWORK )
+*
+*                    Update A32
+*
+                     IF( I2.GT.0 )
+     $                  CALL DGEMM( 'No transpose', 'Transpose', I3, I2,
+     $                              IB, -ONE, WORK, LDWORK,
+     $                              AB( 1+IB, I ), LDAB-1, ONE,
+     $                              AB( 1+KD-IB, I+IB ), LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
+     $                           WORK, LDWORK, ONE, AB( 1, I+KD ),
+     $                           LDAB-1 )
+*
+*                    Copy the upper triangle of A31 back into place.
+*
+                     DO 130 JJ = 1, IB
+                        DO 120 II = 1, MIN( JJ, I3 )
+                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
+  120                   CONTINUE
+  130                CONTINUE
+                  END IF
+               END IF
+  140       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+  150 CONTINUE
+      RETURN
+*
+*     End of DPBTRF
+*
+      END
diff --git a/SRC/dpbtrs.f b/SRC/dpbtrs.f
new file mode 100644
index 00000000..76b086a4
--- /dev/null
+++ b/SRC/dpbtrs.f
@@ -0,0 +1,145 @@
+      SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPBTRS solves a system of linear equations A*X = B with a symmetric
+*  positive definite band matrix A using the Cholesky factorization
+*  A = U**T*U or A = L*L**T computed by DPBTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Solve A*X = B where A = U'*U.
+*
+         DO 10 J = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 J = 1, NRHS
+*
+*           Solve L*X = B, overwriting B with X.
+*
+            CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+*
+*           Solve L'*X = B, overwriting B with X.
+*
+            CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DPBTRS
+*
+      END
diff --git a/SRC/dpocon.f b/SRC/dpocon.f
new file mode 100644
index 00000000..c28af374
--- /dev/null
+++ b/SRC/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/dpoequ.f b/SRC/dpoequ.f
new file mode 100644
index 00000000..a5baa17c
--- /dev/null
+++ b/SRC/dpoequ.f
@@ -0,0 +1,136 @@
+      SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOEQU computes row and column scalings intended to equilibrate a
+*  symmetric positive definite matrix A and reduce its condition number
+*  (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The N-by-N symmetric positive definite matrix whose scaling
+*          factors are to be computed.  Only the diagonal elements of A
+*          are referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) DOUBLE PRECISION
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   SMIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      S( 1 ) = A( 1, 1 )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+      DO 10 I = 2, N
+         S( I ) = A( I, I )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of DPOEQU
+*
+      END
diff --git a/SRC/dporfs.f b/SRC/dporfs.f
new file mode 100644
index 00000000..5a34b611
--- /dev/null
+++ b/SRC/dporfs.f
@@ -0,0 +1,331 @@
+      SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, 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          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPORFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite,
+*  and provides error bounds and backward error estimates for the
+*  solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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(1,N).
+*
+*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, as computed by DPOTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  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 DPOTRS.
+*          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            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DPOTRS, DSYMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPORFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DPORFS
+*
+      END
diff --git a/SRC/dposv.f b/SRC/dposv.f
new file mode 100644
index 00000000..a52c2629
--- /dev/null
+++ b/SRC/dposv.f
@@ -0,0 +1,121 @@
+      SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, 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, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**T* U,  if UPLO = 'U', or
+*     A = L * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is a lower triangular
+*  matrix.  The factored form of A is then used to solve the system of
+*  equations A * X = B.
+*
+*  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 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).
+*
+*  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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPOTRF, DPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL DPOTRF( UPLO, N, A, LDA, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of DPOSV
+*
+      END
diff --git a/SRC/dposvx.f b/SRC/dposvx.f
new file mode 100644
index 00000000..b6083baa
--- /dev/null
+++ b/SRC/dposvx.f
@@ -0,0 +1,377 @@
+      SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
+     $                   S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), S( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+*  compute the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**T* U,  if UPLO = 'U', or
+*        A = L * L**T,  if UPLO = 'L',
+*     where U is an upper triangular matrix and L is a lower triangular
+*     matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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 contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  A and AF will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A, except if FACT = 'F' and
+*          EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  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 triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, in the same storage
+*          format as A.  If EQUED .ne. 'N', then AF is the factored form
+*          of the equilibrated matrix diag(S)*A*diag(S).
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the original
+*          matrix A.
+*
+*          If FACT = 'E', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the equilibrated
+*          matrix A (see the description of A for the form of the
+*          equilibrated matrix).
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  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 EQUED = 'Y',
+*          B is overwritten by diag(S) * 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 if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  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) 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
+*          > 0: if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSY
+      EXTERNAL           LSAME, DLAMCH, DLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF,
+     $                   DPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -9
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -10
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -14
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL DPOTRF( UPLO, N, AF, LDAF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
+     $             FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of DPOSVX
+*
+      END
diff --git a/SRC/dpotf2.f b/SRC/dpotf2.f
new file mode 100644
index 00000000..b7d65e91
--- /dev/null
+++ b/SRC/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/dpotrf.f b/SRC/dpotrf.f
new file mode 100644
index 00000000..8449df6d
--- /dev/null
+++ b/SRC/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/dpotri.f b/SRC/dpotri.f
new file mode 100644
index 00000000..7f7b1d06
--- /dev/null
+++ b/SRC/dpotri.f
@@ -0,0 +1,96 @@
+      SUBROUTINE DPOTRI( 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
+*  =======
+*
+*  DPOTRI computes the inverse of a real symmetric positive definite
+*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+*  computed by DPOTRF.
+*
+*  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 triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, as computed by
+*          DPOTRF.
+*          On exit, the upper or lower triangle of the (symmetric)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  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 (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAUUM, DTRTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+*     Form inv(U)*inv(U)' or inv(L)'*inv(L).
+*
+      CALL DLAUUM( UPLO, N, A, LDA, INFO )
+*
+      RETURN
+*
+*     End of DPOTRI
+*
+      END
diff --git a/SRC/dpotrs.f b/SRC/dpotrs.f
new file mode 100644
index 00000000..0273655e
--- /dev/null
+++ b/SRC/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/dppcon.f b/SRC/dppcon.f
new file mode 100644
index 00000000..c90b38b3
--- /dev/null
+++ b/SRC/dppcon.f
@@ -0,0 +1,176 @@
+      SUBROUTINE DPPCON( UPLO, N, AP, 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, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite packed matrix using
+*  the Cholesky factorization A = U**T*U or A = L*L**T computed by
+*  DPPTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  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) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  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, DLATPS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL DLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL DLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL DLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL DLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = IDAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL DRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DPPCON
+*
+      END
diff --git a/SRC/dppequ.f b/SRC/dppequ.f
new file mode 100644
index 00000000..814b1136
--- /dev/null
+++ b/SRC/dppequ.f
@@ -0,0 +1,168 @@
+      SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, 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
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPEQU computes row and column scalings intended to equilibrate a
+*  symmetric positive definite matrix A in packed storage and reduce
+*  its condition number (with respect to the two-norm).  S contains the
+*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
+*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
+*  This choice of S puts the condition number of B within a factor N of
+*  the smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  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) 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.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) DOUBLE PRECISION
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, JJ
+      DOUBLE PRECISION   SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = AP( 1 )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+      IF( UPPER ) THEN
+*
+*        UPLO = 'U':  Upper triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 10 I = 2, N
+            JJ = JJ + I
+            S( I ) = AP( JJ )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   10    CONTINUE
+*
+      ELSE
+*
+*        UPLO = 'L':  Lower triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 20 I = 2, N
+            JJ = JJ + N - I + 2
+            S( I ) = AP( JJ )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   20    CONTINUE
+      END IF
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 30 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   30    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 40 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   40    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of DPPEQU
+*
+      END
diff --git a/SRC/dpprfs.f b/SRC/dpprfs.f
new file mode 100644
index 00000000..1f2caa87
--- /dev/null
+++ b/SRC/dpprfs.f
@@ -0,0 +1,328 @@
+      SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, 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          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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.
+*
+*  AFP     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,
+*          packed columnwise in a linear array in the same format as A
+*          (see AP).
+*
+*  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 DPPTRS.
+*          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            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DPPTRS, DSPMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+     $               1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DPPRFS
+*
+      END
diff --git a/SRC/dppsv.f b/SRC/dppsv.f
new file mode 100644
index 00000000..87199324
--- /dev/null
+++ b/SRC/dppsv.f
@@ -0,0 +1,133 @@
+      SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**T* U,  if UPLO = 'U', or
+*     A = L * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is a lower triangular
+*  matrix.  The factored form of A is then used to solve the system of
+*  equations A * X = B.
+*
+*  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.
+*
+*  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 factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, in the same storage
+*          format as A.
+*
+*  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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  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 = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPPTRF, DPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL DPPTRF( UPLO, N, AP, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of DPPSV
+*
+      END
diff --git a/SRC/dppsvx.f b/SRC/dppsvx.f
new file mode 100644
index 00000000..00c33b6b
--- /dev/null
+++ b/SRC/dppsvx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
+     $                   X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), S( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+*  compute the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**T* U,  if UPLO = 'U', or
+*        A = L * L**T,  if UPLO = 'L',
+*     where U is an upper triangular matrix and L is a lower triangular
+*     matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFP contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AP and AFP will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 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, except if FACT = 'F'
+*          and EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  The j-th column of A is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  AFP     (input or output) DOUBLE PRECISION array, dimension
+*                            (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U'*U or A = L*L', in the same storage
+*          format as A.  If EQUED .ne. 'N', then AFP is the factored
+*          form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U'*U or A = L*L' of the original matrix A.
+*
+*          If FACT = 'E', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U'*U or A = L*L' of the equilibrated
+*          matrix A (see the description of AP for the form of the
+*          equilibrated matrix).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  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 EQUED = 'Y',
+*          B is overwritten by diag(S) * 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 if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  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 = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSP
+      EXTERNAL           LSAME, DLAMCH, DLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DLAQSP, DPPCON, DPPEQU, DPPRFS,
+     $                   DPPTRF, DPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -7
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -8
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -10
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL DPPTRF( UPLO, N, AFP, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
+     $             WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of DPPSVX
+*
+      END
diff --git a/SRC/dpptrf.f b/SRC/dpptrf.f
new file mode 100644
index 00000000..a5e2a596
--- /dev/null
+++ b/SRC/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/dpptri.f b/SRC/dpptri.f
new file mode 100644
index 00000000..78596083
--- /dev/null
+++ b/SRC/dpptri.f
@@ -0,0 +1,128 @@
+      SUBROUTINE DPPTRI( 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
+*  =======
+*
+*  DPPTRI computes the inverse of a real symmetric positive definite
+*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+*  computed by DPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor is stored in AP;
+*          = 'L':  Lower triangular factor is stored in AP.
+*
+*  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 triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, packed columnwise as
+*          a linear array.  The j-th column of U or L is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*          On exit, the upper or lower triangle of the (symmetric)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ, JJN
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSPR, DTPMV, DTPTRI, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the product inv(U) * inv(U)'.
+*
+         JJ = 0
+         DO 10 J = 1, N
+            JC = JJ + 1
+            JJ = JJ + J
+            IF( J.GT.1 )
+     $         CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
+            AJJ = AP( JJ )
+            CALL DSCAL( J, AJJ, AP( JC ), 1 )
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product inv(L)' * inv(L).
+*
+         JJ = 1
+         DO 20 J = 1, N
+            JJN = JJ + N - J + 1
+            AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
+            IF( J.LT.N )
+     $         CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
+     $                     AP( JJN ), AP( JJ+1 ), 1 )
+            JJ = JJN
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DPPTRI
+*
+      END
diff --git a/SRC/dpptrs.f b/SRC/dpptrs.f
new file mode 100644
index 00000000..876b9ef4
--- /dev/null
+++ b/SRC/dpptrs.f
@@ -0,0 +1,134 @@
+      SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPTRS solves a system of linear equations A*X = B with a symmetric
+*  positive definite matrix A in packed storage using the Cholesky
+*  factorization A = U**T*U or A = L*L**T computed by DPPTRF.
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Solve A*X = B where A = U'*U.
+*
+         DO 10 I = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve L*Y = B, overwriting B with X.
+*
+            CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+*
+*           Solve L'*X = Y, overwriting B with X.
+*
+            CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DPPTRS
+*
+      END
diff --git a/SRC/dptcon.f b/SRC/dptcon.f
new file mode 100644
index 00000000..e340c13d
--- /dev/null
+++ b/SRC/dptcon.f
@@ -0,0 +1,149 @@
+      SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPTCON computes the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite tridiagonal matrix
+*  using the factorization A = L*D*L**T or A = U**T*D*U computed by
+*  DPTTRF.
+*
+*  Norm(inv(A)) is computed by a direct method, and the reciprocal of
+*  the condition number is computed as
+*               RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization of A, as computed by DPTTRF.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the unit bidiagonal factor
+*          U or L from the factorization of A,  as computed by DPTTRF.
+*
+*  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 the
+*          1-norm of inv(A) computed in this routine.
+*
+*  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 method used is described in Nicholas J. Higham, "Efficient
+*  Algorithms for Computing the Condition Number of a Tridiagonal
+*  Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      EXTERNAL           IDAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is positive.
+*
+      DO 10 I = 1, N
+         IF( D( I ).LE.ZERO )
+     $      RETURN
+   10 CONTINUE
+*
+*     Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*        m(i,j) =  abs(A(i,j)), i = j,
+*        m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*     and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*     Solve M(L) * x = e.
+*
+      WORK( 1 ) = ONE
+      DO 20 I = 2, N
+         WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
+   20 CONTINUE
+*
+*     Solve D * M(L)' * x = b.
+*
+      WORK( N ) = WORK( N ) / D( N )
+      DO 30 I = N - 1, 1, -1
+         WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
+   30 CONTINUE
+*
+*     Compute AINVNM = max(x(i)), 1<=i<=n.
+*
+      IX = IDAMAX( N, WORK, 1 )
+      AINVNM = ABS( WORK( IX ) )
+*
+*     Compute the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of DPTCON
+*
+      END
diff --git a/SRC/dpteqr.f b/SRC/dpteqr.f
new file mode 100644
index 00000000..a00c7c76
--- /dev/null
+++ b/SRC/dpteqr.f
@@ -0,0 +1,189 @@
+      SUBROUTINE DPTEQR( 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
+*  =======
+*
+*  DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric positive definite tridiagonal matrix by first factoring the
+*  matrix using DPTTRF, and then calling DBDSQR to compute the singular
+*  values of the bidiagonal factor.
+*
+*  This routine computes the eigenvalues of the positive definite
+*  tridiagonal matrix to high relative accuracy.  This means that if the
+*  eigenvalues range over many orders of magnitude in size, then the
+*  small eigenvalues and corresponding eigenvectors will be computed
+*  more accurately than, for example, with the standard QR method.
+*
+*  The eigenvectors of a full or band symmetric positive definite matrix
+*  can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
+*  reduce this matrix to tridiagonal form. (The reduction to tridiagonal
+*  form, however, may preclude the possibility of obtaining high
+*  relative accuracy in the small eigenvalues of the original matrix, if
+*  these eigenvalues range over many orders of magnitude.)
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'V':  Compute eigenvectors of original symmetric
+*                  matrix also.  Array Z contains the orthogonal
+*                  matrix used to reduce the original matrix to
+*                  tridiagonal form.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*
+*  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 normal exit, D contains the eigenvalues, in descending
+*          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', the orthogonal matrix used in the
+*          reduction to tridiagonal form.
+*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
+*          original symmetric matrix;
+*          if COMPZ = 'I', the orthonormal eigenvectors of the
+*          tridiagonal matrix.
+*          If INFO > 0 on exit, Z contains the eigenvectors associated
+*          with only the stored eigenvalues.
+*          If  COMPZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          COMPZ = 'V' or 'I', LDZ >= max(1,N).
+*
+*  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:  if INFO = i, and i is:
+*                <= N  the Cholesky factorization of the matrix could
+*                      not be performed because the i-th principal minor
+*                      was not positive definite.
+*                > N   the SVD algorithm failed to converge;
+*                      if INFO = N+i, i off-diagonal elements of the
+*                      bidiagonal factor did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSQR, DLASET, DPTTRF, XERBLA
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   C( 1, 1 ), VT( 1, 1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICOMPZ, NRU
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+     $         N ) ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPTEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.GT.0 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+      IF( ICOMPZ.EQ.2 )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Call DPTTRF to factor the matrix.
+*
+      CALL DPTTRF( N, D, E, INFO )
+      IF( INFO.NE.0 )
+     $   RETURN
+      DO 10 I = 1, N
+         D( I ) = SQRT( D( I ) )
+   10 CONTINUE
+      DO 20 I = 1, N - 1
+         E( I ) = E( I )*D( I )
+   20 CONTINUE
+*
+*     Call DBDSQR to compute the singular values/vectors of the
+*     bidiagonal factor.
+*
+      IF( ICOMPZ.GT.0 ) THEN
+         NRU = N
+      ELSE
+         NRU = 0
+      END IF
+      CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
+     $             WORK, INFO )
+*
+*     Square the singular values.
+*
+      IF( INFO.EQ.0 ) THEN
+         DO 30 I = 1, N
+            D( I ) = D( I )*D( I )
+   30    CONTINUE
+      ELSE
+         INFO = N + INFO
+      END IF
+*
+      RETURN
+*
+*     End of DPTEQR
+*
+      END
diff --git a/SRC/dptrfs.f b/SRC/dptrfs.f
new file mode 100644
index 00000000..41bd0058
--- /dev/null
+++ b/SRC/dptrfs.f
@@ -0,0 +1,301 @@
+      SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
+     $                   BERR, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   E( * ), EF( * ), FERR( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite
+*  and tridiagonal, and provides error bounds and backward error
+*  estimates for the solution.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+*  DF      (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization computed by DPTTRF.
+*
+*  EF      (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the unit bidiagonal factor
+*          L from the factorization computed by DPTTRF.
+*
+*  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 DPTTRS.
+*          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 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).
+*
+*  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 (2*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 ..
+      INTEGER            COUNT, I, IX, J, NZ
+      DOUBLE PRECISION   BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2,
+     $                   SAFMIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DPTTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           IDAMAX, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 90 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X.  Also compute
+*        abs(A)*abs(x) + abs(b) for use in the backward error bound.
+*
+         IF( N.EQ.1 ) THEN
+            BI = B( 1, J )
+            DX = D( 1 )*X( 1, J )
+            WORK( N+1 ) = BI - DX
+            WORK( 1 ) = ABS( BI ) + ABS( DX )
+         ELSE
+            BI = B( 1, J )
+            DX = D( 1 )*X( 1, J )
+            EX = E( 1 )*X( 2, J )
+            WORK( N+1 ) = BI - DX - EX
+            WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
+            DO 30 I = 2, N - 1
+               BI = B( I, J )
+               CX = E( I-1 )*X( I-1, J )
+               DX = D( I )*X( I, J )
+               EX = E( I )*X( I+1, J )
+               WORK( N+I ) = BI - CX - DX - EX
+               WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
+   30       CONTINUE
+            BI = B( N, J )
+            CX = E( N-1 )*X( N-1, J )
+            DX = D( N )*X( N, J )
+            WORK( N+N ) = BI - CX - DX
+            WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 40 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   40    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+         DO 50 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   50    CONTINUE
+         IX = IDAMAX( N, WORK, 1 )
+         FERR( J ) = WORK( IX )
+*
+*        Estimate the norm of inv(A).
+*
+*        Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*           m(i,j) =  abs(A(i,j)), i = j,
+*           m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*        and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*        Solve M(L) * x = e.
+*
+         WORK( 1 ) = ONE
+         DO 60 I = 2, N
+            WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
+   60    CONTINUE
+*
+*        Solve D * M(L)' * x = b.
+*
+         WORK( N ) = WORK( N ) / DF( N )
+         DO 70 I = N - 1, 1, -1
+            WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
+   70    CONTINUE
+*
+*        Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
+*
+         IX = IDAMAX( N, WORK, 1 )
+         FERR( J ) = FERR( J )*ABS( WORK( IX ) )
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 80 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+   80    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+   90 CONTINUE
+*
+      RETURN
+*
+*     End of DPTRFS
+*
+      END
diff --git a/SRC/dptsv.f b/SRC/dptsv.f
new file mode 100644
index 00000000..dd5f0bed
--- /dev/null
+++ b/SRC/dptsv.f
@@ -0,0 +1,99 @@
+      SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPTSV computes the solution to a real system of linear equations
+*  A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
+*  matrix, and X and B are N-by-NRHS matrices.
+*
+*  A is factored as A = L*D*L**T, and the factored form of A is then
+*  used to solve the system of equations.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the factorization A = L*D*L**T.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L**T factorization of
+*          A.  (E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U**T*D*U factorization of A.)
+*
+*  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).
+*
+*  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 solution has not been
+*                computed.  The factorization has not been completed
+*                unless i = N.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           DPTTRF, DPTTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPTSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      CALL DPTTRF( N, D, E, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of DPTSV
+*
+      END
diff --git a/SRC/dptsvx.f b/SRC/dptsvx.f
new file mode 100644
index 00000000..4824b355
--- /dev/null
+++ b/SRC/dptsvx.f
@@ -0,0 +1,233 @@
+      SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   E( * ), EF( * ), FERR( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPTSVX uses the factorization A = L*D*L**T to compute the solution
+*  to a real system of linear equations A*X = B, where A is an N-by-N
+*  symmetric positive definite tridiagonal matrix and X and B are
+*  N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
+*     is a unit lower bidiagonal matrix and D is diagonal.  The
+*     factorization can also be regarded as having the form
+*     A = U**T*D*U.
+*
+*  2. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, DF and EF contain the factored form of A.
+*                  D, E, DF, and EF will not be modified.
+*          = 'N':  The matrix A will be copied to DF and EF and
+*                  factored.
+*
+*  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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+*  DF      (input or output) DOUBLE PRECISION array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**T factorization of A.
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**T factorization of A.
+*
+*  EF      (input or output) DOUBLE PRECISION array, dimension (N-1)
+*          If FACT = 'F', then EF is an input argument and on entry
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**T factorization of A.
+*          If FACT = 'N', then EF is an output argument and on exit
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**T factorization of A.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix 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 of INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal condition number of the matrix A.  If RCOND
+*          is less than the machine precision (in particular, if
+*          RCOND = 0), the matrix is singular to working precision.
+*          This condition is indicated by a return code of INFO > 0.
+*
+*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
+*          The forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).
+*
+*  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 (2*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 leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+         CALL DCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 )
+     $      CALL DCOPY( N-1, E, 1, EF, 1 )
+         CALL DPTTRF( N, DF, EF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = DLANST( '1', N, D, E )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
+     $             WORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of DPTSVX
+*
+      END
diff --git a/SRC/dpttrf.f b/SRC/dpttrf.f
new file mode 100644
index 00000000..7f774ee1
--- /dev/null
+++ b/SRC/dpttrf.f
@@ -0,0 +1,152 @@
+      SUBROUTINE DPTTRF( 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
+*  =======
+*
+*  DPTTRF computes the L*D*L' factorization of a real symmetric
+*  positive definite tridiagonal matrix A.  The factorization may also
+*  be regarded as having the form A = U'*D*U.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the L*D*L' factorization of A.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L' factorization of A.
+*          E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U'*D*U factorization of A.
+*
+*  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; if k < N, the factorization could not
+*               be completed, while if k = N, the factorization was
+*               completed, but D(N) <= 0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I4
+      DOUBLE PRECISION   EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MOD
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'DPTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      I4 = MOD( N-1, 4 )
+      DO 10 I = 1, I4
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 30
+         END IF
+         EI = E( I )
+         E( I ) = EI / D( I )
+         D( I+1 ) = D( I+1 ) - E( I )*EI
+   10 CONTINUE
+*
+      DO 20 I = I4 + 1, N - 4, 4
+*
+*        Drop out of the loop if d(i) <= 0: the matrix is not positive
+*        definite.
+*
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 30
+         END IF
+*
+*        Solve for e(i) and d(i+1).
+*
+         EI = E( I )
+         E( I ) = EI / D( I )
+         D( I+1 ) = D( I+1 ) - E( I )*EI
+*
+         IF( D( I+1 ).LE.ZERO ) THEN
+            INFO = I + 1
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+1) and d(i+2).
+*
+         EI = E( I+1 )
+         E( I+1 ) = EI / D( I+1 )
+         D( I+2 ) = D( I+2 ) - E( I+1 )*EI
+*
+         IF( D( I+2 ).LE.ZERO ) THEN
+            INFO = I + 2
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+2) and d(i+3).
+*
+         EI = E( I+2 )
+         E( I+2 ) = EI / D( I+2 )
+         D( I+3 ) = D( I+3 ) - E( I+2 )*EI
+*
+         IF( D( I+3 ).LE.ZERO ) THEN
+            INFO = I + 3
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+3) and d(i+4).
+*
+         EI = E( I+3 )
+         E( I+3 ) = EI / D( I+3 )
+         D( I+4 ) = D( I+4 ) - E( I+3 )*EI
+   20 CONTINUE
+*
+*     Check d(n) for positive definiteness.
+*
+      IF( D( N ).LE.ZERO )
+     $   INFO = N
+*
+   30 CONTINUE
+      RETURN
+*
+*     End of DPTTRF
+*
+      END
diff --git a/SRC/dpttrs.f b/SRC/dpttrs.f
new file mode 100644
index 00000000..9a2a4771
--- /dev/null
+++ b/SRC/dpttrs.f
@@ -0,0 +1,114 @@
+      SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPTTRS solves a tridiagonal system of the form
+*     A * X = B
+*  using the L*D*L' factorization of A computed by DPTTRF.  D is a
+*  diagonal matrix specified in the vector D, L is a unit bidiagonal
+*  matrix whose subdiagonal is specified in the vector E, and X and B
+*  are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          L*D*L' factorization of A.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the unit bidiagonal factor
+*          L from the L*D*L' factorization of A.  E can also be regarded
+*          as the superdiagonal of the unit bidiagonal factor U from the
+*          factorization A = U'*D*U.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPTTS2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) )
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL DPTTS2( N, NRHS, D, E, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB )
+   10    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DPTTRS
+*
+      END
diff --git a/SRC/dptts2.f b/SRC/dptts2.f
new file mode 100644
index 00000000..ce2337d0
--- /dev/null
+++ b/SRC/dptts2.f
@@ -0,0 +1,93 @@
+      SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPTTS2 solves a tridiagonal system of the form
+*     A * X = B
+*  using the L*D*L' factorization of A computed by DPTTRF.  D is a
+*  diagonal matrix specified in the vector D, L is a unit bidiagonal
+*  matrix whose subdiagonal is specified in the vector E, and X and B
+*  are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          L*D*L' factorization of A.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the unit bidiagonal factor
+*          L from the L*D*L' factorization of A.  E can also be regarded
+*          as the superdiagonal of the unit bidiagonal factor U from the
+*          factorization A = U'*D*U.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         IF( N.EQ.1 )
+     $      CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB )
+         RETURN
+      END IF
+*
+*     Solve A * X = B using the factorization A = L*D*L',
+*     overwriting each right hand side vector with its solution.
+*
+      DO 30 J = 1, NRHS
+*
+*           Solve L * x = b.
+*
+         DO 10 I = 2, N
+            B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+   10    CONTINUE
+*
+*           Solve D * L' * x = b.
+*
+         B( N, J ) = B( N, J ) / D( N )
+         DO 20 I = N - 1, 1, -1
+            B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
+   20    CONTINUE
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of DPTTS2
+*
+      END
diff --git a/SRC/drscl.f b/SRC/drscl.f
new file mode 100644
index 00000000..a13e96d8
--- /dev/null
+++ b/SRC/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/dsbev.f b/SRC/dsbev.f
new file mode 100644
index 00000000..cfe524e4
--- /dev/null
+++ b/SRC/dsbev.f
@@ -0,0 +1,205 @@
+      SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, 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, KD, LDAB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBEV computes all the eigenvalues and, optionally, eigenvectors of
+*  a real symmetric band 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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  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 (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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDWRK, ISCALE
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSB
+      EXTERNAL           LSAME, DLAMCH, DLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASCL, DSBTRD, DSCAL, DSTEQR, DSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            W( 1 ) = AB( 1, 1 )
+         ELSE
+            W( 1 ) = AB( KD+1, 1 )
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of DSBEV
+*
+      END
diff --git a/SRC/dsbevd.f b/SRC/dsbevd.f
new file mode 100644
index 00000000..73adab72
--- /dev/null
+++ b/SRC/dsbevd.f
@@ -0,0 +1,268 @@
+      SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+     $                   LWORK, IWORK, LIWORK, 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, KD, LDAB, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBEVD computes all the eigenvalues and, optionally, eigenvectors of
+*  a real symmetric band matrix A. If eigenvectors are desired, it uses
+*  a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  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/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.
+*          IF N <= 1,                LWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 2, LWORK must be at least 2*N.
+*          If JOBZ  = 'V' and N > 2, LWORK must be at least
+*                         ( 1 + 5*N + 2*N**2 ).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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 LIWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
+     $                   LLWRK2, LWMIN
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSB
+      EXTERNAL           LSAME, DLAMCH, DLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLACPY, DLASCL, DSBTRD, DSCAL, DSTEDC,
+     $                   DSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LIWMIN = 1
+         LWMIN = 1
+      ELSE
+         IF( WANTZ ) THEN
+            LIWMIN = 3 + 5*N
+            LWMIN = 1 + 5*N + 2*N**2
+         ELSE
+            LIWMIN = 1
+            LWMIN = 2*N
+         END IF
+      END IF
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AB( 1, 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = INDWRK + N*N
+      LLWRK2 = LWORK - INDWK2 + 1
+      CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+         CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+     $               ZERO, WORK( INDWK2 ), N )
+         CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL DSCAL( N, ONE / SIGMA, W, 1 )
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of DSBEVD
+*
+      END
diff --git a/SRC/dsbevx.f b/SRC/dsbevx.f
new file mode 100644
index 00000000..18b7d935
--- /dev/null
+++ b/SRC/dsbevx.f
@@ -0,0 +1,415 @@
+      SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
+     $                   VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric band matrix A.  Eigenvalues and eigenvectors can
+*  be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
+*          If JOBZ = 'V', the N-by-N orthogonal matrix used in the
+*                         reduction to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'V', then
+*          LDQ >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AB to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  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 (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ,
+     $                   NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSB
+      EXTERNAL           LSAME, DLAMCH, DLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL,
+     $                   DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -18
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         M = 1
+         IF( LOWER ) THEN
+            TMP1 = AB( 1, 1 )
+         ELSE
+            TMP1 = AB( KD+1, 1 )
+         END IF
+         IF( VALEIG ) THEN
+            IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
+     $         M = 0
+         END IF
+         IF( M.EQ.1 ) THEN
+            W( 1 ) = TMP1
+            IF( WANTZ )
+     $         Z( 1, 1 ) = ONE
+         END IF
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      END IF
+      ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDWRK = INDE + N
+      CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ),
+     $             WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call DSTERF or SSTEQR.  If this fails for some
+*     eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by DSTEIN.
+*
+         DO 20 J = 1, M
+            CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSBEVX
+*
+      END
diff --git a/SRC/dsbgst.f b/SRC/dsbgst.f
new file mode 100644
index 00000000..a8ea6210
--- /dev/null
+++ b/SRC/dsbgst.f
@@ -0,0 +1,1345 @@
+      SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
+     $                   LDX, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO, VECT
+      INTEGER            INFO, KA, KB, LDAB, LDBB, LDX, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBGST reduces a real symmetric-definite banded generalized
+*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,
+*  such that C has the same bandwidth as A.
+*
+*  B must have been previously factorized as S**T*S by DPBSTF, using a
+*  split Cholesky factorization. A is overwritten by C = X**T*A*X, where
+*  X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
+*  bandwidth of A.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form the transformation matrix X;
+*          = 'V':  form X.
+*
+*  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 matrices A and B.  N >= 0.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the transformed matrix X**T*A*X, stored in the same
+*          format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input) DOUBLE PRECISION array, dimension (LDBB,N)
+*          The banded factor S from the split Cholesky factorization of
+*          B, as returned by DPBSTF, stored in the first KB+1 rows of
+*          the array.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
+*          If VECT = 'V', the n-by-n matrix X.
+*          If VECT = 'N', the array X is not referenced.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.
+*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
+*
+*  WORK    (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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPDATE, UPPER, WANTX
+      INTEGER            I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
+     $                   KA1, KB1, KBT, L, M, NR, NRT, NX
+      DOUBLE PRECISION   BII, RA, RA1, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGER, DLAR2V, DLARGV, DLARTG, DLARTV, DLASET,
+     $                   DROT, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTX = LSAME( VECT, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      KA1 = KA + 1
+      KB1 = KB + 1
+      INFO = 0
+      IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      INCA = LDAB*KA1
+*
+*     Initialize X to the unit matrix, if needed
+*
+      IF( WANTX )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX )
+*
+*     Set M to the splitting point m. It must be the same value as is
+*     used in DPBSTF. The chosen value allows the arrays WORK and RWORK
+*     to be of dimension (N).
+*
+      M = ( N+KB ) / 2
+*
+*     The routine works in two phases, corresponding to the two halves
+*     of the split Cholesky factorization of B as S**T*S where
+*
+*     S = ( U    )
+*         ( M  L )
+*
+*     with U upper triangular of order m, and L lower triangular of
+*     order n-m. S has the same bandwidth as B.
+*
+*     S is treated as a product of elementary matrices:
+*
+*     S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
+*
+*     where S(i) is determined by the i-th row of S.
+*
+*     In phase 1, the index i takes the values n, n-1, ... , m+1;
+*     in phase 2, it takes the values 1, 2, ... , m.
+*
+*     For each value of i, the current matrix A is updated by forming
+*     inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
+*     the band of A. The bulge is then pushed down toward the bottom of
+*     A in phase 1, and up toward the top of A in phase 2, by applying
+*     plane rotations.
+*
+*     There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
+*     of them are linearly independent, so annihilating a bulge requires
+*     only 2*kb-1 plane rotations. The rotations are divided into a 1st
+*     set of kb-1 rotations, and a 2nd set of kb rotations.
+*
+*     Wherever possible, rotations are generated and applied in vector
+*     operations of length NR between the indices J1 and J2 (sometimes
+*     replaced by modified values NRT, J1T or J2T).
+*
+*     The cosines and sines of the rotations are stored in the array
+*     WORK. The cosines of the 1st set of rotations are stored in
+*     elements n+2:n+m-kb-1 and the sines of the 1st set in elements
+*     2:m-kb-1; the cosines of the 2nd set are stored in elements
+*     n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
+*
+*     The bulges are not formed explicitly; nonzero elements outside the
+*     band are created only when they are required for generating new
+*     rotations; they are stored in the array WORK, in positions where
+*     they are later overwritten by the sines of the rotations which
+*     annihilate them.
+*
+*     **************************** Phase 1 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = N, M + 1, -1
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M + KA + 1, N - 1
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = N + 1
+   10 CONTINUE
+      IF( UPDATE ) THEN
+         I = I - 1
+         KBT = MIN( KB, I-1 )
+         I0 = I - 1
+         I1 = MIN( N, I+KA )
+         I2 = I - KBT + KA1
+         IF( I.LT.M+1 ) THEN
+            UPDATE = .FALSE.
+            I = I + 1
+            I0 = M
+            IF( KA.EQ.0 )
+     $         GO TO 480
+            GO TO 10
+         END IF
+      ELSE
+         I = I + KA
+         IF( I.GT.N-1 )
+     $      GO TO 480
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( KB1, I )
+            DO 20 J = I, I1
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+   20       CONTINUE
+            DO 30 J = MAX( 1, I-KA ), I
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+   30       CONTINUE
+            DO 60 K = I - KBT, I - 1
+               DO 40 J = I - KBT, K
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( J-I+KB1, I )*AB( K-I+KA1, I ) -
+     $                               BB( K-I+KB1, I )*AB( J-I+KA1, I ) +
+     $                               AB( KA1, I )*BB( J-I+KB1, I )*
+     $                               BB( K-I+KB1, I )
+   40          CONTINUE
+               DO 50 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( K-I+KB1, I )*AB( J-I+KA1, I )
+   50          CONTINUE
+   60       CONTINUE
+            DO 80 J = I, I1
+               DO 70 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( K-I+KB1, I )*AB( I-J+KA1, J )
+   70          CONTINUE
+   80       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+     $                       BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+KA1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 130 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i,i-k+ka+1)
+*
+                  CALL DLARTG( AB( K+1, I-K+KA ), RA1,
+     $                         WORK( N+I-K+KA-M ), WORK( I-K+KA-M ),
+     $                         RA )
+*
+*                 create nonzero element a(i-k,i-k+ka+1) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( KB1-K, I )*RA1
+                  WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+     $                          WORK( I-K+KA-M )*AB( 1, I-K+KA )
+                  AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
+     $                              WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 90 J = J2T, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
+               AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
+   90       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
+     $                      WORK( N+J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 100 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  100          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, WORK( N+J2-M ),
+     $                      WORK( J2-M ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 110 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA,
+     $                         WORK( N+J2-M ), WORK( J2-M ), KA1 )
+  110       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 120 J = J2, J1, KA1
+                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J-M ), WORK( J-M ) )
+  120          CONTINUE
+            END IF
+  130    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt,i-kbt+ka+1) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
+            END IF
+         END IF
+*
+         DO 170 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 140 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA,
+     $                         AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ),
+     $                         WORK( J2-KA ), KA1 )
+  140       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 150 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               WORK( N+J ) = WORK( N+J-KA )
+  150       CONTINUE
+            DO 160 J = J2, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+1 )
+               AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
+  160       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  170    CONTINUE
+*
+         DO 210 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
+     $                      WORK( N+J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 180 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  180          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, WORK( N+J2 ),
+     $                      WORK( J2 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 190 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  190       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 200 J = J2, J1, KA1
+                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  200          CONTINUE
+            END IF
+  210    CONTINUE
+*
+         DO 230 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 220 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA,
+     $                         WORK( N+J2-M ), WORK( J2-M ), KA1 )
+  220       CONTINUE
+  230    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 240 J = N - 1, I - KB + 2*KA + 1, -1
+               WORK( N+J-M ) = WORK( N+J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  240       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( 1, I )
+            DO 250 J = I, I1
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  250       CONTINUE
+            DO 260 J = MAX( 1, I-KA ), I
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  260       CONTINUE
+            DO 290 K = I - KBT, I - 1
+               DO 270 J = I - KBT, K
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( I-J+1, J )*AB( I-K+1, K ) -
+     $                             BB( I-K+1, K )*AB( I-J+1, J ) +
+     $                             AB( 1, I )*BB( I-J+1, J )*
+     $                             BB( I-K+1, K )
+  270          CONTINUE
+               DO 280 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( I-K+1, K )*AB( I-J+1, J )
+  280          CONTINUE
+  290       CONTINUE
+            DO 310 J = I, I1
+               DO 300 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( I-K+1, K )*AB( J-I+1, I )
+  300          CONTINUE
+  310       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+     $                       BB( KBT+1, I-KBT ), LDBB-1,
+     $                       X( M+1, I-KBT ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 360 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i-k+ka+1,i)
+*
+                  CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ),
+     $                         WORK( I-K+KA-M ), RA )
+*
+*                 create nonzero element a(i-k+ka+1,i-k) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( K+1, I-K )*RA1
+                  WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+     $                          WORK( I-K+KA-M )*AB( KA1, I-K )
+                  AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
+     $                             WORK( N+I-K+KA-M )*AB( KA1, I-K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 320 J = J2T, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
+  320       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
+     $                      KA1, WORK( N+J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 330 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  330          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 340 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  340       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 350 J = J2, J1, KA1
+                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J-M ), WORK( J-M ) )
+  350          CONTINUE
+            END IF
+  360    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt+ka+1,i-kbt) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
+            END IF
+         END IF
+*
+         DO 400 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 370 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
+     $                         AB( KA1-L, J2-KA+1 ), INCA,
+     $                         WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
+  370       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 380 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               WORK( N+J ) = WORK( N+J-KA )
+  380       CONTINUE
+            DO 390 J = J2, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
+  390       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  400    CONTINUE
+*
+         DO 440 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
+     $                      WORK( N+J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 410 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  410          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 420 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  420       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 430 J = J2, J1, KA1
+                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  430          CONTINUE
+            END IF
+  440    CONTINUE
+*
+         DO 460 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 450 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  450       CONTINUE
+  460    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 470 J = N - 1, I - KB + 2*KA + 1, -1
+               WORK( N+J-M ) = WORK( N+J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  470       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 10
+*
+  480 CONTINUE
+*
+*     **************************** Phase 2 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = 1, M
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M - KA - 1, 2, -1
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = 0
+  490 CONTINUE
+      IF( UPDATE ) THEN
+         I = I + 1
+         KBT = MIN( KB, M-I )
+         I0 = I + 1
+         I1 = MAX( 1, I-KA )
+         I2 = I + KBT - KA1
+         IF( I.GT.M ) THEN
+            UPDATE = .FALSE.
+            I = I - 1
+            I0 = M + 1
+            IF( KA.EQ.0 )
+     $         RETURN
+            GO TO 490
+         END IF
+      ELSE
+         I = I - KA
+         IF( I.LT.2 )
+     $      RETURN
+      END IF
+*
+      IF( I.LT.M-KBT ) THEN
+         NX = M
+      ELSE
+         NX = N
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( KB1, I )
+            DO 500 J = I1, I
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+  500       CONTINUE
+            DO 510 J = I, MIN( N, I+KA )
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+  510       CONTINUE
+            DO 540 K = I + 1, I + KBT
+               DO 520 J = K, I + KBT
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( I-J+KB1, J )*AB( I-K+KA1, K ) -
+     $                               BB( I-K+KB1, K )*AB( I-J+KA1, J ) +
+     $                               AB( KA1, I )*BB( I-J+KB1, J )*
+     $                               BB( I-K+KB1, K )
+  520          CONTINUE
+               DO 530 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( I-K+KB1, K )*AB( I-J+KA1, J )
+  530          CONTINUE
+  540       CONTINUE
+            DO 560 J = I1, I
+               DO 550 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( I-K+KB1, K )*AB( J-I+KA1, I )
+  550          CONTINUE
+  560       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ),
+     $                       LDBB-1, X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+KA1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 610 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i+k-ka-1,i)
+*
+                  CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ),
+     $                         WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k-ka-1,i+k) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( KB1-K, I+K )*RA1
+                  WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+     $                               WORK( I+K-KA )*AB( 1, I+K )
+                  AB( 1, I+K ) = WORK( I+K-KA )*T +
+     $                           WORK( N+I+K-KA )*AB( 1, I+K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 570 J = J1, J2T, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
+  570       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
+     $                      WORK( N+J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 580 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA, WORK( N+J1 ),
+     $                         WORK( J1 ), KA1 )
+  580          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, WORK( N+J1 ),
+     $                      WORK( J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 590 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+     $                         WORK( J1T ), KA1 )
+  590       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 600 J = J1, J2, KA1
+                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  600          CONTINUE
+            END IF
+  610    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt-ka-1,i+kbt) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
+            END IF
+         END IF
+*
+         DO 650 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 620 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J1T+KA ), INCA,
+     $                         AB( L+1, J1T+KA-1 ), INCA,
+     $                         WORK( N+M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  620       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 630 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+  630       CONTINUE
+            DO 640 J = J1, J2, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
+  640       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  650    CONTINUE
+*
+         DO 690 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 660 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA,
+     $                         WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
+  660          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 670 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA,
+     $                         WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  670       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 680 J = J1, J2, KA1
+                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+M-KB+J ), WORK( M-KB+J ) )
+  680          CONTINUE
+            END IF
+  690    CONTINUE
+*
+         DO 710 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 700 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+     $                         WORK( J1T ), KA1 )
+  700       CONTINUE
+  710    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
+               WORK( N+J ) = WORK( N+J+KA )
+               WORK( J ) = WORK( J+KA )
+  720       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( 1, I )
+            DO 730 J = I1, I
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  730       CONTINUE
+            DO 740 J = I, MIN( N, I+KA )
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  740       CONTINUE
+            DO 770 K = I + 1, I + KBT
+               DO 750 J = K, I + KBT
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( J-I+1, I )*AB( K-I+1, I ) -
+     $                             BB( K-I+1, I )*AB( J-I+1, I ) +
+     $                             AB( 1, I )*BB( J-I+1, I )*
+     $                             BB( K-I+1, I )
+  750          CONTINUE
+               DO 760 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( K-I+1, I )*AB( J-I+1, I )
+  760          CONTINUE
+  770       CONTINUE
+            DO 790 J = I1, I
+               DO 780 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( K-I+1, I )*AB( I-J+1, J )
+  780          CONTINUE
+  790       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1,
+     $                       X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 840 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i,i+k-ka-1)
+*
+                  CALL DLARTG( AB( KA1-K, I+K-KA ), RA1,
+     $                         WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k,i+k-ka-1) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( K+1, I )*RA1
+                  WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+     $                               WORK( I+K-KA )*AB( KA1, I+K-KA )
+                  AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
+     $                                WORK( N+I+K-KA )*AB( KA1, I+K-KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 800 J = J1, J2T, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
+  800       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
+     $                      WORK( N+J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 810 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
+  810          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, WORK( N+J1 ),
+     $                      WORK( J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 820 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         WORK( N+J1T ), WORK( J1T ), KA1 )
+  820       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 830 J = J1, J2, KA1
+                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  830          CONTINUE
+            END IF
+  840    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt,i+kbt-ka-1) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
+            END IF
+         END IF
+*
+         DO 880 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 850 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
+     $                         AB( KA1-L, J1T+L-1 ), INCA,
+     $                         WORK( N+M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  850       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 860 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+  860       CONTINUE
+            DO 870 J = J1, J2, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
+  870       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  880    CONTINUE
+*
+         DO 920 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 890 L = 1, KA - 1
+                  CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ),
+     $                         KA1 )
+  890          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 900 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  900       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 910 J = J1, J2, KA1
+                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+M-KB+J ), WORK( M-KB+J ) )
+  910          CONTINUE
+            END IF
+  920    CONTINUE
+*
+         DO 940 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 930 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         WORK( N+J1T ), WORK( J1T ), KA1 )
+  930       CONTINUE
+  940    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
+               WORK( N+J ) = WORK( N+J+KA )
+               WORK( J ) = WORK( J+KA )
+  950       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 490
+*
+*     End of DSBGST
+*
+      END
diff --git a/SRC/dsbgv.f b/SRC/dsbgv.f
new file mode 100644
index 00000000..b3a56435
--- /dev/null
+++ b/SRC/dsbgv.f
@@ -0,0 +1,188 @@
+      SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, 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, KA, KB, LDAB, LDBB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), W( * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
+*  and banded, and B is also positive definite.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**T*S, as returned by DPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  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, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**T*B*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= 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, and i is:
+*             <= N:  the algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then DPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER, WANTZ
+      CHARACTER          VECT
+      INTEGER            IINFO, INDE, INDWRK
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     Reduce to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                INFO )
+      END IF
+      RETURN
+*
+*     End of DSBGV
+*
+      END
diff --git a/SRC/dsbgvd.f b/SRC/dsbgvd.f
new file mode 100644
index 00000000..36b4f50d
--- /dev/null
+++ b/SRC/dsbgvd.f
@@ -0,0 +1,271 @@
+      SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
+     $                   Z, LDZ, WORK, LWORK, IWORK, LIWORK, 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, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), W( * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite banded eigenproblem, of the
+*  form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric and
+*  banded, and B is also positive definite.  If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**T*S, as returned by DPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  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, with the i-th column of Z holding the
+*          eigenvector associated with W(i).  The eigenvectors are
+*          normalized so Z**T*B*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= 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 dimension of the array WORK.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= 3*N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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 algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then DPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          VECT
+      INTEGER            IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2,
+     $                   LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLACPY, DPBSTF, DSBGST, DSBTRD, DSTEDC,
+     $                   DSTERF, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LIWMIN = 1
+         LWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LIWMIN = 3 + 5*N
+         LWMIN = 1 + 5*N + 2*N**2
+      ELSE
+         LIWMIN = 1
+         LWMIN = 2*N
+      END IF
+*
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -14
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = INDWRK + N*N
+      LLWRK2 = LWORK - INDWK2 + 1
+      CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     Reduce to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+         CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+     $               ZERO, WORK( INDWK2 ), N )
+         CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DSBGVD
+*
+      END
diff --git a/SRC/dsbgvx.f b/SRC/dsbgvx.f
new file mode 100644
index 00000000..ac65458b
--- /dev/null
+++ b/SRC/dsbgvx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB,
+     $                   LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z,
+     $                   LDZ, WORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
+     $                   N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
+     $                   W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a real generalized symmetric-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric
+*  and banded, and B is also positive definite.  Eigenvalues and
+*  eigenvectors can be selected by specifying either all eigenvalues,
+*  a range of values or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**T*S, as returned by DPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
+*          If JOBZ = 'V', the n-by-n matrix used in the reduction of
+*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
+*          and consequently C to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'N',
+*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  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, with the i-th column of Z holding the
+*          eigenvector associated with W(i).  The eigenvectors are
+*          normalized so Z**T*B*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (7*N)
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (M)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvalues that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0 : successful exit
+*          < 0 : if INFO = -i, the i-th argument had an illegal value
+*          <= N: if INFO = i, then i eigenvectors failed to converge.
+*                  Their indices are stored in IFAIL.
+*          > N : DPBSTF returned an error code; i.e.,
+*                if INFO = N + i, for 1 <= i <= N, then the leading
+*                minor of order i of B is not positive definite.
+*                The factorization of B could not be completed and
+*                no eigenvalues or eigenvectors were computed.
+*
+*  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 ..
+      LOGICAL            ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
+      CHARACTER          ORDER, VECT
+      INTEGER            I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
+     $                   INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
+      DOUBLE PRECISION   TMP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMV, DLACPY, DPBSTF, DSBGST, DSBTRD,
+     $                   DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -8
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -10
+      ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
+         INFO = -12
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -14
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -15
+            ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -16
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -21
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
+     $             WORK, IINFO )
+*
+*     Reduce symmetric band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDWRK = INDE + N
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ),
+     $             WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call DSTERF or SSTEQR.  If this fails for some
+*     eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+         IF( .NOT.WANTZ ) THEN
+            CALL DSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired,
+*     call DSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply transformation matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by DSTEIN.
+*
+         DO 20 J = 1, M
+            CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+   30 CONTINUE
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSBGVX
+*
+      END
diff --git a/SRC/dsbtrd.f b/SRC/dsbtrd.f
new file mode 100644
index 00000000..788b8fa7
--- /dev/null
+++ b/SRC/dsbtrd.f
@@ -0,0 +1,552 @@
+      SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, 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, VECT
+      INTEGER            INFO, KD, LDAB, LDQ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSBTRD reduces a real symmetric band matrix A to symmetric
+*  tridiagonal form T by an orthogonal similarity transformation:
+*  Q**T * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form Q;
+*          = 'V':  form Q;
+*          = 'U':  update a matrix X, by forming X*Q.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          On exit, the diagonal elements of AB are overwritten by the
+*          diagonal elements of the tridiagonal matrix T; if KD > 0, the
+*          elements on the first superdiagonal (if UPLO = 'U') or the
+*          first subdiagonal (if UPLO = 'L') are overwritten by the
+*          off-diagonal elements of T; the rest of AB is overwritten by
+*          values generated during the reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T.
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          On entry, if VECT = 'U', then Q must contain an N-by-N
+*          matrix X; if VECT = 'N' or 'V', then Q need not be set.
+*
+*          On exit:
+*          if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
+*          if VECT = 'U', Q contains the product X*Q;
+*          if VECT = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
+*
+*  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
+*  ===============
+*
+*  Modified by Linda Kaufman, Bell Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            INITQ, UPPER, WANTQ
+      INTEGER            I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
+     $                   J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
+     $                   KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, DROT,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INITQ = LSAME( VECT, 'V' )
+      WANTQ = INITQ .OR. LSAME( VECT, 'U' )
+      UPPER = LSAME( UPLO, 'U' )
+      KD1 = KD + 1
+      KDM1 = KD - 1
+      INCX = LDAB - 1
+      IQEND = 1
+*
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD1 ) THEN
+         INFO = -6
+      ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSBTRD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize Q to the unit matrix, if needed
+*
+      IF( INITQ )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+*     Wherever possible, plane rotations are generated and applied in
+*     vector operations of length NR over the index set J1:J2:KD1.
+*
+*     The cosines and sines of the plane rotations are stored in the
+*     arrays D and WORK.
+*
+      INCA = KD1*LDAB
+      KDN = MIN( N-1, KD )
+      IF( UPPER ) THEN
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to tridiagonal form, working with upper triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            DO 90 I = 1, N - 2
+*
+*              Reduce i-th row of matrix to tridiagonal form
+*
+               DO 80 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
+     $                            KD1, D( J1 ), KD1 )
+*
+*                    apply rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    DLARTV or DROT is used
+*
+                     IF( NR.GE.2*KD-1 ) THEN
+                        DO 10 L = 1, KD - 1
+                           CALL DLARTV( NR, AB( L+1, J1-1 ), INCA,
+     $                                  AB( L, J1 ), INCA, D( J1 ),
+     $                                  WORK( J1 ), KD1 )
+   10                   CONTINUE
+*
+                     ELSE
+                        JEND = J1 + ( NR-1 )*KD1
+                        DO 20 JINC = J1, JEND, KD1
+                           CALL DROT( KDM1, AB( 2, JINC-1 ), 1,
+     $                                AB( 1, JINC ), 1, D( JINC ),
+     $                                WORK( JINC ) )
+   20                   CONTINUE
+                     END IF
+                  END IF
+*
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i,i+k-1)
+*                       within the band
+*
+                        CALL DLARTG( AB( KD-K+3, I+K-2 ),
+     $                               AB( KD-K+2, I+K-1 ), D( I+K-1 ),
+     $                               WORK( I+K-1 ), TEMP )
+                        AB( KD-K+3, I+K-2 ) = TEMP
+*
+*                       apply rotation from the right
+*
+                        CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1,
+     $                             AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
+     $                            AB( KD, J1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the left
+*
+                  IF( NR.GT.0 ) THEN
+                     IF( 2*KD-1.LT.NR ) THEN
+*
+*                    Dependent on the the number of diagonals either
+*                    DLARTV or DROT is used
+*
+                        DO 30 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA,
+     $                                     AB( KD-L+1, J1+L ), INCA,
+     $                                     D( J1 ), WORK( J1 ), KD1 )
+   30                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 40 JIN = J1, J1END, KD1
+                              CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX,
+     $                                   AB( KD, JIN+1 ), INCX,
+     $                                   D( JIN ), WORK( JIN ) )
+   40                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX,
+     $                                AB( KD, LAST+1 ), INCX, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 50 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), WORK( J ) )
+   50                   CONTINUE
+                     ELSE
+*
+                        DO 60 J = J1, J2, KD1
+                           CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), WORK( J ) )
+   60                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 70 J = J1, J2, KD1
+*
+*                    create nonzero element a(j-1,j+kd) outside the band
+*                    and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
+                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
+   70             CONTINUE
+   80          CONTINUE
+   90       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           copy off-diagonal elements to E
+*
+            DO 100 I = 1, N - 1
+               E( I ) = AB( KD, I+1 )
+  100       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 110 I = 1, N - 1
+               E( I ) = ZERO
+  110       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 120 I = 1, N
+            D( I ) = AB( KD1, I )
+  120    CONTINUE
+*
+      ELSE
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to tridiagonal form, working with lower triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            DO 210 I = 1, N - 2
+*
+*              Reduce i-th column of matrix to tridiagonal form
+*
+               DO 200 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA,
+     $                            WORK( J1 ), KD1, D( J1 ), KD1 )
+*
+*                    apply plane rotations from one side
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    DLARTV or DROT is used
+*
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 130 L = 1, KD - 1
+                           CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
+     $                                  AB( KD1-L+1, J1-KD1+L ), INCA,
+     $                                  D( J1 ), WORK( J1 ), KD1 )
+  130                   CONTINUE
+                     ELSE
+                        JEND = J1 + KD1*( NR-1 )
+                        DO 140 JINC = J1, JEND, KD1
+                           CALL DROT( KDM1, AB( KD, JINC-KD ), INCX,
+     $                                AB( KD1, JINC-KD ), INCX,
+     $                                D( JINC ), WORK( JINC ) )
+  140                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i+k-1,i)
+*                       within the band
+*
+                        CALL DLARTG( AB( K-1, I ), AB( K, I ),
+     $                               D( I+K-1 ), WORK( I+K-1 ), TEMP )
+                        AB( K-1, I ) = TEMP
+*
+*                       apply rotation from the left
+*
+                        CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1,
+     $                             AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
+     $                            AB( 2, J1-1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    DLARTV or DROT is used
+*
+                  IF( NR.GT.0 ) THEN
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 150 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA,
+     $                                     AB( L+1, J1 ), INCA, D( J1 ),
+     $                                     WORK( J1 ), KD1 )
+  150                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 160 J1INC = J1, J1END, KD1
+                              CALL DROT( KDM1, AB( 3, J1INC-1 ), 1,
+     $                                   AB( 2, J1INC ), 1, D( J1INC ),
+     $                                   WORK( J1INC ) )
+  160                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL DROT( LEND, AB( 3, LAST-1 ), 1,
+     $                                AB( 2, LAST ), 1, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+*
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 170 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), WORK( J ) )
+  170                   CONTINUE
+                     ELSE
+*
+                        DO 180 J = J1, J2, KD1
+                           CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), WORK( J ) )
+  180                   CONTINUE
+                     END IF
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 190 J = J1, J2, KD1
+*
+*                    create nonzero element a(j+kd,j-1) outside the
+*                    band and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( KD1, J )
+                     AB( KD1, J ) = D( J )*AB( KD1, J )
+  190             CONTINUE
+  200          CONTINUE
+  210       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           copy off-diagonal elements to E
+*
+            DO 220 I = 1, N - 1
+               E( I ) = AB( 2, I )
+  220       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 230 I = 1, N - 1
+               E( I ) = ZERO
+  230       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 240 I = 1, N
+            D( I ) = AB( 1, I )
+  240    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSBTRD
+*
+      END
diff --git a/SRC/dsgesv.f b/SRC/dsgesv.f
new file mode 100644
index 00000000..5be14625
--- /dev/null
+++ b/SRC/dsgesv.f
@@ -0,0 +1,338 @@
+      SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK,
+     +                   SWORK, ITER, INFO)
+*
+*  -- LAPACK PROTOTYPE driver routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     February 2007
+*
+*     ..
+*     .. WARNING: PROTOTYPE ..
+*     This is an LAPACK PROTOTYPE routine which means that the
+*     interface of this routine is likely to be changed in the future
+*     based on community feedback.
+*
+*     ..
+*     .. Scalar Arguments ..
+      INTEGER INFO,ITER,LDA,LDB,LDX,N,NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER IPIV(*)
+      REAL SWORK(*)
+      DOUBLE PRECISION A(LDA,*),B(LDB,*),WORK(N,*),X(LDX,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSGESV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+*  DSGESV first attempts to factorize the matrix in SINGLE PRECISION 
+*  and use this factorization within an iterative refinement procedure to
+*  produce a solution with DOUBLE PRECISION normwise backward error
+*  quality (see below). If the approach fails the method switches to a
+*  DOUBLE PRECISION factorization and solve.
+*
+*  The iterative refinement is not going to be a winning strategy if
+*  the ratio SINGLE PRECISION performance over DOUBLE PRECISION performance
+*  is too small. A reasonable strategy should take the number of right-hand
+*  sides and the size of the matrix into account. This might be done with a 
+*  call to ILAENV in the future. Up to now, we always try iterative refinement.
+*
+*  The iterative refinement process is stopped if
+*      ITER > ITERMAX
+*  or for all the RHS we have:
+*      RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX 
+*  where
+*      o ITER is the number of the current iteration in the iterative
+*        refinement process
+*      o RNRM is the infinity-norm of the residual
+*      o XNRM is the infinity-norm of the solution
+*      o ANRM is the infinity-operator-norm of the matrix A
+*      o EPS is the machine epsilon returned by DLAMCH('Epsilon')
+*  The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively.
+*
+*  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 or input/ouptut) DOUBLE PRECISION array,
+*          dimension (LDA,N)
+*          On entry, the N-by-N coefficient matrix A.
+*          On exit, if iterative refinement has been successfully used
+*          (INFO.EQ.0 and ITER.GE.0, see description below), then A is
+*          unchanged, if double precision factorization has been used
+*          (INFO.EQ.0 and ITER.LT.0, see description below), then the
+*          array A contains the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  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).
+*          Corresponds either to the single precision factorization 
+*          (if INFO.EQ.0 and ITER.GE.0) or the double precision 
+*          factorization (if INFO.EQ.0 and ITER.LT.0).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          The N-by-NRHS matrix of right hand side matrix 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, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N*NRHS)
+*          This array is used to hold the residual vectors.
+*
+*  SWORK   (workspace) REAL array, dimension (N*(N+NRHS))
+*          This array is used to use the single precision matrix and the 
+*          right-hand sides or solutions in single precision.
+*
+*  ITER    (output) INTEGER
+*          < 0: iterative refinement has failed, double precision
+*               factorization has been performed
+*               -1 : taking into account machine parameters, N, NRHS, it
+*                    is a priori not worth working in SINGLE PRECISION
+*               -2 : overflow of an entry when moving from double to
+*                    SINGLE PRECISION
+*               -3 : failure of SGETRF
+*               -31: stop the iterative refinement after the 30th
+*                    iterations
+*          > 0: iterative refinement has been sucessfully used.
+*               Returns the number of iterations
+*
+*  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) computed in DOUBLE PRECISION is
+*                exactly zero.  The factorization has been completed,
+*                but the factor U is exactly singular, so the solution
+*                could not be computed.
+*
+*  =========
+*
+*     .. Parameters ..
+      DOUBLE PRECISION NEGONE,ONE
+      PARAMETER (NEGONE=-1.0D+0,ONE=1.0D+0)
+*
+*     .. Local Scalars ..
+      LOGICAL DOITREF
+      INTEGER I,IITER,ITERMAX,OK,PTSA,PTSX
+      DOUBLE PRECISION ANRM,BWDMAX,CTE,EPS,RNRM,XNRM
+*
+*     .. External Subroutines ..
+      EXTERNAL DAXPY,DGEMM,DLACPY,DLAG2S,SLAG2D,
+     +         SGETRF,SGETRS,XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER IDAMAX
+      DOUBLE PRECISION DLAMCH,DLANGE
+      EXTERNAL IDAMAX,DLAMCH,DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS,DBLE,MAX,SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      ITERMAX = 30
+      BWDMAX = 1.0E+00
+      DOITREF = .TRUE.
+*
+      OK = 0
+      INFO = 0
+      ITER = 0
+*
+*     Test the input parameters.
+*
+      IF (N.LT.0) THEN
+          INFO = -1
+      ELSE IF (NRHS.LT.0) THEN
+          INFO = -2
+      ELSE IF (LDA.LT.MAX(1,N)) THEN
+          INFO = -4
+      ELSE IF (LDB.LT.MAX(1,N)) THEN
+          INFO = -7
+      ELSE IF (LDX.LT.MAX(1,N)) THEN
+          INFO = -9
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DSGESV',-INFO)
+          RETURN
+      END IF
+*
+*     Quick return if (N.EQ.0).
+*
+      IF (N.EQ.0) RETURN
+*
+*     Skip single precision iterative refinement if a priori slower
+*     than double precision factorization.
+*
+      IF (.NOT.DOITREF) THEN
+          ITER = -1
+          GO TO 40
+      END IF
+*
+*     Compute some constants.
+*
+      ANRM = DLANGE('I',N,N,A,LDA,WORK)
+      EPS = DLAMCH('Epsilon')
+      CTE = ANRM*EPS*SQRT(DBLE(N))*BWDMAX
+*
+*     Set the pointers PTSA, PTSX for referencing SA and SX in SWORK.
+*
+      PTSA = 1
+      PTSX = PTSA + N*N
+*
+*     Convert B from double precision to single precision and store the
+*     result in SX.
+*
+      CALL DLAG2S(N,NRHS,B,LDB,SWORK(PTSX),N,INFO)
+*
+      IF (INFO.NE.0) THEN
+          ITER = -2
+          GO TO 40
+      END IF
+*
+*     Convert A from double precision to single precision and store the
+*     result in SA.
+*
+      CALL DLAG2S(N,N,A,LDA,SWORK(PTSA),N,INFO)
+*
+      IF (INFO.NE.0) THEN
+          ITER = -2
+          GO TO 40
+      END IF
+*
+*     Compute the LU factorization of SA.
+*
+      CALL SGETRF(N,N,SWORK(PTSA),N,IPIV,INFO)
+*
+      IF (INFO.NE.0) THEN
+          ITER = -3
+          GO TO 40
+      END IF
+*
+*     Solve the system SA*SX = SB.
+*
+      CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+     +            SWORK(PTSX),N,INFO)
+*
+*     Convert SX back to double precision
+*
+      CALL SLAG2D(N,NRHS,SWORK(PTSX),N,X,LDX,INFO)
+*
+*     Compute R = B - AX (R is WORK).
+*
+      CALL DLACPY('All',N,NRHS,B,LDB,WORK,N)
+*
+      CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,LDA,X,
+     +           LDX,ONE,WORK,N)
+*
+*     Check whether the NRHS normwised backward errors satisfy the
+*     stopping criterion. If yes, set ITER=0 and return.
+*
+      DO I = 1,NRHS
+          XNRM = ABS(X(IDAMAX(N,X(1,I),1),I))
+          RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I))
+          IF (RNRM.GT.XNRM*CTE) GOTO 10
+      END DO
+*
+*     If we are here, the NRHS normwised backward errors satisfy the
+*     stopping criterion. We are good to exit.
+*
+      ITER = 0
+      RETURN
+*
+ 10   CONTINUE
+*
+      DO 30 IITER = 1,ITERMAX
+*
+*         Convert R (in WORK) from double precision to single precision
+*         and store the result in SX.
+*
+          CALL DLAG2S(N,NRHS,WORK,N,SWORK(PTSX),N,INFO)
+*
+          IF (INFO.NE.0) THEN
+              ITER = -2
+              GO TO 40
+          END IF
+*
+*         Solve the system SA*SX = SR.
+*
+          CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+     +                SWORK(PTSX),N,INFO)
+*
+*         Convert SX back to double precision and update the current
+*         iterate.
+*
+          CALL SLAG2D(N,NRHS,SWORK(PTSX),N,WORK,N,INFO)
+*
+          CALL DAXPY(N*NRHS,ONE,WORK,1,X,1)
+*
+*         Compute R = B - AX (R is WORK).
+*
+          CALL DLACPY('All',N,NRHS,B,LDB,WORK,N)
+*
+          CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,
+     +               LDA,X,LDX,ONE,WORK,N)
+*
+*         Check whether the NRHS normwised backward errors satisfy the
+*         stopping criterion. If yes, set ITER=IITER>0 and return.
+*
+          DO I = 1,NRHS
+              XNRM = ABS(X(IDAMAX(N,X(1,I),1),I))
+              RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I))
+              IF (RNRM.GT.XNRM*CTE) GOTO 20
+          END DO
+*
+*         If we are here, the NRHS normwised backward errors satisfy the 
+*         stopping criterion, we are good to exit.
+*
+          ITER = IITER
+*
+          RETURN
+*
+   20     CONTINUE
+*
+   30 CONTINUE
+*
+*     If we are at this place of the code, this is because we have
+*     performed ITER=ITERMAX iterations and never satisified the stopping
+*     criterion, set up the ITER flag accordingly and follow up on double
+*     precision routine.
+*
+      ITER = -ITERMAX - 1
+*
+   40 CONTINUE
+*
+*     Single-precision iterative refinement failed to converge to a
+*     satisfactory solution, so we resort to double precision.
+*
+      CALL DGETRF(N,N,A,LDA,IPIV,INFO)
+*
+      CALL DLACPY('All',N,NRHS,B,LDB,X,LDX)
+*
+      IF (INFO.EQ.0) THEN
+          CALL DGETRS('No transpose',N,NRHS,A,LDA,IPIV,X,LDX,INFO)
+      END IF
+*
+      RETURN
+*
+*     End of DSGESV.
+*
+      END
diff --git a/SRC/dspcon.f b/SRC/dspcon.f
new file mode 100644
index 00000000..3e695d0e
--- /dev/null
+++ b/SRC/dspcon.f
@@ -0,0 +1,162 @@
+      SUBROUTINE DSPCON( UPLO, N, AP, 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, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric packed matrix A using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by DSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSPTRF.
+*
+*  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, IP, KASE
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DSPTRS, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         IP = N*( N+1 ) / 2
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP - I
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         IP = 1
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP + N - I + 1
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL DSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of DSPCON
+*
+      END
diff --git a/SRC/dspev.f b/SRC/dspev.f
new file mode 100644
index 00000000..64582c99
--- /dev/null
+++ b/SRC/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/dspevd.f b/SRC/dspevd.f
new file mode 100644
index 00000000..3dd4efab
--- /dev/null
+++ b/SRC/dspevd.f
@@ -0,0 +1,252 @@
+      SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
+     $                   IWORK, LIWORK, 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, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPEVD computes all the eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A in packed storage. If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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/output) DOUBLE PRECISION array,
+*                                         dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least
+*                                                 1 + 6*N + N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTZ
+      INTEGER            IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,
+     $                   LLWORK, LWMIN
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSP
+      EXTERNAL           LSAME, DLAMCH, DLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LIWMIN = 3 + 5*N
+               LWMIN = 1 + 6*N + N**2
+            ELSE
+               LIWMIN = 1
+               LWMIN = 2*N
+            END IF
+         END IF
+         IWORK( 1 ) = LIWMIN
+         WORK( 1 ) = LWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -9
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+*     tridiagonal matrix, then call DOPMTR to multiply it by the
+*     Householder transformations represented in AP.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         INDWRK = INDTAU + N
+         LLWORK = LWORK - INDWRK + 1
+         CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                LLWORK, IWORK, LIWORK, INFO )
+         CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL DSCAL( N, ONE / SIGMA, W, 1 )
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of DSPEVD
+*
+      END
diff --git a/SRC/dspevx.f b/SRC/dspevx.f
new file mode 100644
index 00000000..68611699
--- /dev/null
+++ b/SRC/dspevx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL,
+     $                   INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A in packed storage.  Eigenvalues/vectors
+*  can be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the selected eigenvalues in ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  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 (8*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1,
+     $                   J, JJ, NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSP
+      EXTERNAL           LSAME, DLAMCH, DLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ,
+     $                   DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -14
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = AP( 1 )
+         ELSE
+            IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
+               M = 1
+               W( 1 ) = AP( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      END IF
+      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+      INDTAU = 1
+      INDE = INDTAU + N
+      INDD = INDE + N
+      INDWRK = INDD + N
+      CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
+     $             WORK( INDTAU ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call DSTERF or DOPGTR and SSTEQR.  If this fails
+*     for some eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                   WORK( INDWRK ), IINFO )
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 20
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by DSTEIN.
+*
+         CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   20 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 40 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 30 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   30       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSPEVX
+*
+      END
diff --git a/SRC/dspgst.f b/SRC/dspgst.f
new file mode 100644
index 00000000..8e121a94
--- /dev/null
+++ b/SRC/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/dspgv.f b/SRC/dspgv.f
new file mode 100644
index 00000000..737a1ee3
--- /dev/null
+++ b/SRC/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/dspgvd.f b/SRC/dspgvd.f
new file mode 100644
index 00000000..23850cf7
--- /dev/null
+++ b/SRC/dspgvd.f
@@ -0,0 +1,277 @@
+      SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                   LWORK, IWORK, LIWORK, 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, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AP( * ), BP( * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
+*  B are assumed to be symmetric, stored in packed format, and B is also
+*  positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= 2*N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  DPPTRF or DSPEVD returned an error code:
+*             <= N:  if INFO = i, DSPEVD failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J, LIWMIN, LWMIN, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LIWMIN = 3 + 5*N
+               LWMIN = 1 + 6*N + 2*N**2
+            ELSE
+               LIWMIN = 1
+               LWMIN = 2*N
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of BP.
+*
+      CALL DPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK,
+     $             LIWORK, INFO )
+      LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) )
+      LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*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
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DSPGVD
+*
+      END
diff --git a/SRC/dspgvx.f b/SRC/dspgvx.f
new file mode 100644
index 00000000..de44ee90
--- /dev/null
+++ b/SRC/dspgvx.f
@@ -0,0 +1,292 @@
+      SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
+     $                   IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   AP( * ), BP( * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A
+*  and B are assumed to be symmetric, stored in packed storage, and B
+*  is also positive definite.  Eigenvalues and eigenvectors can be
+*  selected by specifying either a range of values or a range of indices
+*  for the desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A and B are stored;
+*          = 'L':  Lower triangle of A and B are stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix pencil (A,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.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  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 (8*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  DPPTRF or DSPEVX returned an error code:
+*             <= N:  if INFO = i, DSPEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      UPPER = LSAME( UPLO, 'U' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL ) THEN
+               INFO = -9
+            END IF
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 ) THEN
+               INFO = -10
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -11
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL DPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
+     $             W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            DO 10 J = 1, M
+               CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   10       CONTINUE
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, M
+               CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DSPGVX
+*
+      END
diff --git a/SRC/dsprfs.f b/SRC/dsprfs.f
new file mode 100644
index 00000000..265c2bdd
--- /dev/null
+++ b/SRC/dsprfs.f
@@ -0,0 +1,335 @@
+      SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, 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          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  AFP     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The factored form of the matrix A.  AFP contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by DSPTRF, stored as a packed
+*          triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSPTRF.
+*
+*  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 DSPTRS.
+*          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            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DSPMV, DSPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+     $               1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DSPRFS
+*
+      END
diff --git a/SRC/dspsv.f b/SRC/dspsv.f
new file mode 100644
index 00000000..16de3057
--- /dev/null
+++ b/SRC/dspsv.f
@@ -0,0 +1,148 @@
+      SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric matrix stored in packed format and X
+*  and B are N-by-NRHS matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**T,  if UPLO = 'U', or
+*     A = L * D * L**T,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, D is symmetric and block diagonal with 1-by-1
+*  and 2-by-2 diagonal blocks.  The factored form of A is then used to
+*  solve the system of equations A * X = B.
+*
+*  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.
+*
+*  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, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by DSPTRF.  If IPIV(k) > 0, then rows and columns
+*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
+*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
+*          then rows and columns k-1 and -IPIV(k) were interchanged and
+*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and
+*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
+*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
+*          diagonal block.
+*
+*  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).
+*
+*  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.
+*
+*  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 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSPTRF, DSPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL DSPTRF( UPLO, N, AP, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of DSPSV
+*
+      END
diff --git a/SRC/dspsvx.f b/SRC/dspsvx.f
new file mode 100644
index 00000000..46218269
--- /dev/null
+++ b/SRC/dspsvx.f
@@ -0,0 +1,277 @@
+      SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, 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          FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
+*  A = L*D*L**T to compute the solution to a real system of linear
+*  equations A * X = B, where A is an N-by-N symmetric matrix stored
+*  in packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AFP and IPIV contain the factored form of
+*                  A.  AP, AFP and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*  AFP     (input or output) DOUBLE PRECISION array, dimension
+*                            (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains details of the interchanges and the block structure
+*          of D, as determined by DSPTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by DSPTRF.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix 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.
+*
+*  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.  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  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   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSP
+      EXTERNAL           LSAME, DLAMCH, DLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DSPCON, DSPRFS, DSPTRF, DSPTRS,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL DSPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, IWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of DSPSVX
+*
+      END
diff --git a/SRC/dsptrd.f b/SRC/dsptrd.f
new file mode 100644
index 00000000..6d3390e3
--- /dev/null
+++ b/SRC/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/dsptrf.f b/SRC/dsptrf.f
new file mode 100644
index 00000000..8b8a9185
--- /dev/null
+++ b/SRC/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/dsptri.f b/SRC/dsptri.f
new file mode 100644
index 00000000..406352cd
--- /dev/null
+++ b/SRC/dsptri.f
@@ -0,0 +1,334 @@
+      SUBROUTINE DSPTRI( UPLO, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPTRI computes the inverse of a real symmetric indefinite matrix
+*  A in packed storage using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by DSPTRF.
+*
+*  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.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by DSPTRF,
+*          stored as a packed triangular matrix.
+*
+*          On exit, if INFO = 0, the (symmetric) inverse of the original
+*          matrix, stored as a packed triangular matrix. The j-th column
+*          of inv(A) is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+*          if UPLO = 'L',
+*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSPTRF.
+*
+*  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            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+      DOUBLE PRECISION   AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSPMV, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         KP = N*( N+1 ) / 2
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP - INFO
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         KP = 1
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP + N - INFO + 1
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         KCNEXT = KC + K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC+K-1 ) = ONE / AP( KC+K-1 )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        DDOT( K-1, WORK, 1, AP( KC ), 1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+K-1 ) )
+            AK = AP( KC+K-1 ) / T
+            AKP1 = AP( KCNEXT+K ) / T
+            AKKP1 = AP( KCNEXT+K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KC+K-1 ) = AKP1 / D
+            AP( KCNEXT+K ) = AK / D
+            AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        DDOT( K-1, WORK, 1, AP( KC ), 1 )
+               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+     $                            DDOT( K-1, AP( KC ), 1, AP( KCNEXT ),
+     $                            1 )
+               CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+               CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
+     $                     AP( KCNEXT ), 1 )
+               AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+     $                          DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT + K + 1
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            KPC = ( KP-1 )*KP / 2 + 1
+            CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+            KX = KPC + KP - 1
+            DO 40 J = KP + 1, K - 1
+               KX = KX + J - 1
+               TEMP = AP( KC+J-1 )
+               AP( KC+J-1 ) = AP( KX )
+               AP( KX ) = TEMP
+   40       CONTINUE
+            TEMP = AP( KC+K-1 )
+            AP( KC+K-1 ) = AP( KPC+KP-1 )
+            AP( KPC+KP-1 ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC+K+K-1 )
+               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+               AP( KC+K+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         KC = KCNEXT
+         GO TO 30
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         NPP = N*( N+1 ) / 2
+         K = N
+         KC = NPP
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         KCNEXT = KC - ( N-K+2 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC ) = ONE / AP( KC )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+1 ) )
+            AK = AP( KCNEXT ) / T
+            AKP1 = AP( KC ) / T
+            AKKP1 = AP( KCNEXT+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KCNEXT ) = AKP1 / D
+            AP( KC ) = AK / D
+            AP( KCNEXT+1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+     $                          DDOT( N-K, AP( KC+1 ), 1,
+     $                          AP( KCNEXT+2 ), 1 )
+               CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+               CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KCNEXT+2 ), 1 )
+               AP( KCNEXT ) = AP( KCNEXT ) -
+     $                        DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT - ( N-K+3 )
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+            IF( KP.LT.N )
+     $         CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+            KX = KC + KP - K
+            DO 70 J = K + 1, KP - 1
+               KX = KX + N - J + 1
+               TEMP = AP( KC+J-K )
+               AP( KC+J-K ) = AP( KX )
+               AP( KX ) = TEMP
+   70       CONTINUE
+            TEMP = AP( KC )
+            AP( KC ) = AP( KPC )
+            AP( KPC ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC-N+K-1 )
+               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+               AP( KC-N+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         KC = KCNEXT
+         GO TO 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSPTRI
+*
+      END
diff --git a/SRC/dsptrs.f b/SRC/dsptrs.f
new file mode 100644
index 00000000..9f03f797
--- /dev/null
+++ b/SRC/dsptrs.f
@@ -0,0 +1,377 @@
+      SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPTRS solves a system of linear equations A*X = B with a real
+*  symmetric matrix A stored in packed format using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by DSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSPTRF.
+*
+*  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, KC, KP
+      DOUBLE PRECISION   AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER, DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Solve A*X = B, where A = U*D*U'.
+*
+*        First solve U*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         KC = KC - K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(U(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K-1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K-1 )
+     $         CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(U(K)), where U(K) is the transformation
+*           stored in columns K-1 and K of A.
+*
+            CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+            CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+     $                 B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+K-2 )
+            AKM1 = AP( KC-1 ) / AKM1K
+            AK = AP( KC+K-1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / AKM1K
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            KC = KC - K + 1
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + K
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+     $                  AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + 2*K + 1
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(L(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+     $                    LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
+            KC = KC + N - K + 1
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(L(K)), where L(K) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            IF( K.LT.N-1 ) THEN
+               CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+     $                    LDB, B( K+2, 1 ), LDB )
+               CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+     $                    B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+1 )
+            AKM1 = AP( KC ) / AKM1K
+            AK = AP( KC+N-K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / AKM1K
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            KC = KC + 2*( N-K ) + 1
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         KC = KC - ( N-K+1 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(L'(K-1)), where L(K-1) is the transformation
+*           stored in columns K-1 and K of A.
+*
+            IF( K.LT.N ) THEN
+               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
+     $                     LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC - ( N-K+2 )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSPTRS
+*
+      END
diff --git a/SRC/dstebz.f b/SRC/dstebz.f
new file mode 100644
index 00000000..b540715b
--- /dev/null
+++ b/SRC/dstebz.f
@@ -0,0 +1,652 @@
+      SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
+     $                   M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*     8-18-00:  Increase FUDGE factor for T3E (eca)
+*
+*     .. Scalar Arguments ..
+      CHARACTER          ORDER, RANGE
+      INTEGER            IL, INFO, IU, M, N, NSPLIT
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEBZ computes the eigenvalues of a symmetric tridiagonal
+*  matrix T.  The user may ask for all eigenvalues, all eigenvalues
+*  in the half-open interval (VL, VU], or the IL-th through IU-th
+*  eigenvalues.
+*
+*  To avoid overflow, the matrix must be scaled so that its
+*  largest element is no greater than overflow**(1/2) *
+*  underflow**(1/4) in absolute value, and for greatest
+*  accuracy, it should not be much smaller than that.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966.
+*
+*  Arguments
+*  =========
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': ("All")   all eigenvalues will be found.
+*          = 'V': ("Value") all eigenvalues in the half-open interval
+*                           (VL, VU] will be found.
+*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+*                           entire matrix) will be found.
+*
+*  ORDER   (input) CHARACTER*1
+*          = 'B': ("By Block") the eigenvalues will be grouped by
+*                              split-off block (see IBLOCK, ISPLIT) and
+*                              ordered from smallest to largest within
+*                              the block.
+*          = 'E': ("Entire matrix")
+*                              the eigenvalues for the entire matrix
+*                              will be ordered from smallest to
+*                              largest.
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal matrix T.  N >= 0.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues.  Eigenvalues less than or equal
+*          to VL, or greater than VU, will not be returned.  VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute tolerance for the eigenvalues.  An eigenvalue
+*          (or cluster) is considered to be located if it has been
+*          determined to lie in an interval whose width is ABSTOL or
+*          less.  If ABSTOL is less than or equal to zero, then ULP*|T|
+*          will be used, where |T| means the 1-norm of T.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+*  M       (output) INTEGER
+*          The actual number of eigenvalues found. 0 <= M <= N.
+*          (See also the description of INFO=2,3.)
+*
+*  NSPLIT  (output) INTEGER
+*          The number of diagonal blocks in the matrix T.
+*          1 <= NSPLIT <= N.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, the first M elements of W will contain the
+*          eigenvalues.  (DSTEBZ may use the remaining N-M elements as
+*          workspace.)
+*
+*  IBLOCK  (output) INTEGER array, dimension (N)
+*          At each row/column j where E(j) is zero or small, the
+*          matrix T is considered to split into a block diagonal
+*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which
+*          block (from 1 to the number of blocks) the eigenvalue W(i)
+*          belongs.  (DSTEBZ may use the remaining N-M elements as
+*          workspace.)
+*
+*  ISPLIT  (output) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*          (Only the first NSPLIT elements will actually be used, but
+*          since the user cannot know a priori what value NSPLIT will
+*          have, N words must be reserved for ISPLIT.)
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  some or all of the eigenvalues failed to converge or
+*                were not computed:
+*                =1 or 3: Bisection failed to converge for some
+*                        eigenvalues; these eigenvalues are flagged by a
+*                        negative block number.  The effect is that the
+*                        eigenvalues may not be as accurate as the
+*                        absolute and relative tolerances.  This is
+*                        generally caused by unexpectedly inaccurate
+*                        arithmetic.
+*                =2 or 3: RANGE='I' only: Not all of the eigenvalues
+*                        IL:IU were found.
+*                        Effect: M < IU+1-IL
+*                        Cause:  non-monotonic arithmetic, causing the
+*                                Sturm sequence to be non-monotonic.
+*                        Cure:   recalculate, using RANGE='A', and pick
+*                                out eigenvalues IL:IU.  In some cases,
+*                                increasing the PARAMETER "FUDGE" may
+*                                make things work.
+*                = 4:    RANGE='I', and the Gershgorin interval
+*                        initially used was too small.  No eigenvalues
+*                        were computed.
+*                        Probable cause: your machine has sloppy
+*                                        floating-point arithmetic.
+*                        Cure: Increase the PARAMETER "FUDGE",
+*                              recompile, and try again.
+*
+*  Internal Parameters
+*  ===================
+*
+*  RELFAC  DOUBLE PRECISION, default = 2.0e0
+*          The relative tolerance.  An interval (a,b] lies within
+*          "relative tolerance" if  b-a < RELFAC*ulp*max(|a|,|b|),
+*          where "ulp" is the machine precision (distance from 1 to
+*          the next larger floating point number.)
+*
+*  FUDGE   DOUBLE PRECISION, default = 2
+*          A "fudge factor" to widen the Gershgorin intervals.  Ideally,
+*          a value of 1 should work, but on machines with sloppy
+*          arithmetic, this needs to be larger.  The default for
+*          publicly released versions should be large enough to handle
+*          the worst machine around.  Note that this has no effect
+*          on accuracy of the solution.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, HALF
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   HALF = 1.0D0 / TWO )
+      DOUBLE PRECISION   FUDGE, RELFAC
+      PARAMETER          ( FUDGE = 2.1D0, RELFAC = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NCNVRG, TOOFEW
+      INTEGER            IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+     $                   IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
+     $                   ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
+     $                   NWU
+      DOUBLE PRECISION   ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
+     $                   TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUMMA( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, ILAENV, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAEBZ, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Decode RANGE
+*
+      IF( LSAME( RANGE, 'A' ) ) THEN
+         IRANGE = 1
+      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+         IRANGE = 2
+      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+         IRANGE = 3
+      ELSE
+         IRANGE = 0
+      END IF
+*
+*     Decode ORDER
+*
+      IF( LSAME( ORDER, 'B' ) ) THEN
+         IORDER = 2
+      ELSE IF( LSAME( ORDER, 'E' ) ) THEN
+         IORDER = 1
+      ELSE
+         IORDER = 0
+      END IF
+*
+*     Check for Errors
+*
+      IF( IRANGE.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IORDER.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( IRANGE.EQ.2 ) THEN
+         IF( VL.GE.VU )
+     $      INFO = -5
+      ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+     $          THEN
+         INFO = -6
+      ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
+     $          THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEBZ', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize error flags
+*
+      INFO = 0
+      NCNVRG = .FALSE.
+      TOOFEW = .FALSE.
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Simplifications:
+*
+      IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
+     $   IRANGE = 1
+*
+*     Get machine constants
+*     NB is the minimum vector length for vector bisection, or 0
+*     if only scalar is to be done.
+*
+      SAFEMN = DLAMCH( 'S' )
+      ULP = DLAMCH( 'P' )
+      RTOLI = ULP*RELFAC
+      NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
+      IF( NB.LE.1 )
+     $   NB = 0
+*
+*     Special Case when N=1
+*
+      IF( N.EQ.1 ) THEN
+         NSPLIT = 1
+         ISPLIT( 1 ) = 1
+         IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
+            M = 0
+         ELSE
+            W( 1 ) = D( 1 )
+            IBLOCK( 1 ) = 1
+            M = 1
+         END IF
+         RETURN
+      END IF
+*
+*     Compute Splitting Points
+*
+      NSPLIT = 1
+      WORK( N ) = ZERO
+      PIVMIN = ONE
+*
+*DIR$ NOVECTOR
+      DO 10 J = 2, N
+         TMP1 = E( J-1 )**2
+         IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
+            ISPLIT( NSPLIT ) = J - 1
+            NSPLIT = NSPLIT + 1
+            WORK( J-1 ) = ZERO
+         ELSE
+            WORK( J-1 ) = TMP1
+            PIVMIN = MAX( PIVMIN, TMP1 )
+         END IF
+   10 CONTINUE
+      ISPLIT( NSPLIT ) = N
+      PIVMIN = PIVMIN*SAFEMN
+*
+*     Compute Interval and ATOLI
+*
+      IF( IRANGE.EQ.3 ) THEN
+*
+*        RANGE='I': Compute the interval containing eigenvalues
+*                   IL through IU.
+*
+*        Compute Gershgorin interval for entire (split) matrix
+*        and use it as the initial interval
+*
+         GU = D( 1 )
+         GL = D( 1 )
+         TMP1 = ZERO
+*
+         DO 20 J = 1, N - 1
+            TMP2 = SQRT( WORK( J ) )
+            GU = MAX( GU, D( J )+TMP1+TMP2 )
+            GL = MIN( GL, D( J )-TMP1-TMP2 )
+            TMP1 = TMP2
+   20    CONTINUE
+*
+         GU = MAX( GU, D( N )+TMP1 )
+         GL = MIN( GL, D( N )-TMP1 )
+         TNORM = MAX( ABS( GL ), ABS( GU ) )
+         GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
+         GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
+*
+*        Compute Iteration parameters
+*
+         ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+         IF( ABSTOL.LE.ZERO ) THEN
+            ATOLI = ULP*TNORM
+         ELSE
+            ATOLI = ABSTOL
+         END IF
+*
+         WORK( N+1 ) = GL
+         WORK( N+2 ) = GL
+         WORK( N+3 ) = GU
+         WORK( N+4 ) = GU
+         WORK( N+5 ) = GL
+         WORK( N+6 ) = GU
+         IWORK( 1 ) = -1
+         IWORK( 2 ) = -1
+         IWORK( 3 ) = N + 1
+         IWORK( 4 ) = N + 1
+         IWORK( 5 ) = IL - 1
+         IWORK( 6 ) = IU
+*
+         CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
+     $                WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+     $                IWORK, W, IBLOCK, IINFO )
+*
+         IF( IWORK( 6 ).EQ.IU ) THEN
+            WL = WORK( N+1 )
+            WLU = WORK( N+3 )
+            NWL = IWORK( 1 )
+            WU = WORK( N+4 )
+            WUL = WORK( N+2 )
+            NWU = IWORK( 4 )
+         ELSE
+            WL = WORK( N+2 )
+            WLU = WORK( N+4 )
+            NWL = IWORK( 2 )
+            WU = WORK( N+3 )
+            WUL = WORK( N+1 )
+            NWU = IWORK( 3 )
+         END IF
+*
+         IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+            INFO = 4
+            RETURN
+         END IF
+      ELSE
+*
+*        RANGE='A' or 'V' -- Set ATOLI
+*
+         TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+     $           ABS( D( N ) )+ABS( E( N-1 ) ) )
+*
+         DO 30 J = 2, N - 1
+            TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
+     $              ABS( E( J ) ) )
+   30    CONTINUE
+*
+         IF( ABSTOL.LE.ZERO ) THEN
+            ATOLI = ULP*TNORM
+         ELSE
+            ATOLI = ABSTOL
+         END IF
+*
+         IF( IRANGE.EQ.2 ) THEN
+            WL = VL
+            WU = VU
+         ELSE
+            WL = ZERO
+            WU = ZERO
+         END IF
+      END IF
+*
+*     Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
+*     NWL accumulates the number of eigenvalues .le. WL,
+*     NWU accumulates the number of eigenvalues .le. WU
+*
+      M = 0
+      IEND = 0
+      INFO = 0
+      NWL = 0
+      NWU = 0
+*
+      DO 70 JB = 1, NSPLIT
+         IOFF = IEND
+         IBEGIN = IOFF + 1
+         IEND = ISPLIT( JB )
+         IN = IEND - IOFF
+*
+         IF( IN.EQ.1 ) THEN
+*
+*           Special Case -- IN=1
+*
+            IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
+     $         NWL = NWL + 1
+            IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
+     $         NWU = NWU + 1
+            IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
+     $          D( IBEGIN )-PIVMIN ) ) THEN
+               M = M + 1
+               W( M ) = D( IBEGIN )
+               IBLOCK( M ) = JB
+            END IF
+         ELSE
+*
+*           General Case -- IN > 1
+*
+*           Compute Gershgorin Interval
+*           and use it as the initial interval
+*
+            GU = D( IBEGIN )
+            GL = D( IBEGIN )
+            TMP1 = ZERO
+*
+            DO 40 J = IBEGIN, IEND - 1
+               TMP2 = ABS( E( J ) )
+               GU = MAX( GU, D( J )+TMP1+TMP2 )
+               GL = MIN( GL, D( J )-TMP1-TMP2 )
+               TMP1 = TMP2
+   40       CONTINUE
+*
+            GU = MAX( GU, D( IEND )+TMP1 )
+            GL = MIN( GL, D( IEND )-TMP1 )
+            BNORM = MAX( ABS( GL ), ABS( GU ) )
+            GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
+            GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
+*
+*           Compute ATOLI for the current submatrix
+*
+            IF( ABSTOL.LE.ZERO ) THEN
+               ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
+            ELSE
+               ATOLI = ABSTOL
+            END IF
+*
+            IF( IRANGE.GT.1 ) THEN
+               IF( GU.LT.WL ) THEN
+                  NWL = NWL + IN
+                  NWU = NWU + IN
+                  GO TO 70
+               END IF
+               GL = MAX( GL, WL )
+               GU = MIN( GU, WU )
+               IF( GL.GE.GU )
+     $            GO TO 70
+            END IF
+*
+*           Set Up Initial Interval
+*
+            WORK( N+1 ) = GL
+            WORK( N+IN+1 ) = GU
+            CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+            NWL = NWL + IWORK( 1 )
+            NWU = NWU + IWORK( IN+1 )
+            IWOFF = M - IWORK( 1 )
+*
+*           Compute Eigenvalues
+*
+            ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+     $              LOG( TWO ) ) + 2
+            CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+*           Copy Eigenvalues Into W and IBLOCK
+*           Use -JB for block number for unconverged eigenvalues.
+*
+            DO 60 J = 1, IOUT
+               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+*
+*              Flag non-convergence.
+*
+               IF( J.GT.IOUT-IINFO ) THEN
+                  NCNVRG = .TRUE.
+                  IB = -JB
+               ELSE
+                  IB = JB
+               END IF
+               DO 50 JE = IWORK( J ) + 1 + IWOFF,
+     $                 IWORK( J+IN ) + IWOFF
+                  W( JE ) = TMP1
+                  IBLOCK( JE ) = IB
+   50          CONTINUE
+   60       CONTINUE
+*
+            M = M + IM
+         END IF
+   70 CONTINUE
+*
+*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+*
+      IF( IRANGE.EQ.3 ) THEN
+         IM = 0
+         IDISCL = IL - 1 - NWL
+         IDISCU = NWU - IU
+*
+         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+            DO 80 JE = 1, M
+               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+                  IDISCL = IDISCL - 1
+               ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+                  IDISCU = IDISCU - 1
+               ELSE
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+   80       CONTINUE
+            M = IM
+         END IF
+         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+*
+*           Code to deal with effects of bad arithmetic:
+*           Some low eigenvalues to be discarded are not in (WL,WLU],
+*           or high eigenvalues to be discarded are not in (WUL,WU]
+*           so just kill off the smallest IDISCL/largest IDISCU
+*           eigenvalues, by simply finding the smallest/largest
+*           eigenvalue(s).
+*
+*           (If N(w) is monotone non-decreasing, this should never
+*               happen.)
+*
+            IF( IDISCL.GT.0 ) THEN
+               WKILL = WU
+               DO 100 JDISC = 1, IDISCL
+                  IW = 0
+                  DO 90 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                   ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+   90             CONTINUE
+                  IBLOCK( IW ) = 0
+  100          CONTINUE
+            END IF
+            IF( IDISCU.GT.0 ) THEN
+*
+               WKILL = WL
+               DO 120 JDISC = 1, IDISCU
+                  IW = 0
+                  DO 110 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                   ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+  110             CONTINUE
+                  IBLOCK( IW ) = 0
+  120          CONTINUE
+            END IF
+            IM = 0
+            DO 130 JE = 1, M
+               IF( IBLOCK( JE ).NE.0 ) THEN
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+  130       CONTINUE
+            M = IM
+         END IF
+         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+            TOOFEW = .TRUE.
+         END IF
+      END IF
+*
+*     If ORDER='B', do nothing -- the eigenvalues are already sorted
+*        by block.
+*     If ORDER='E', sort the eigenvalues from smallest to largest
+*
+      IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
+         DO 150 JE = 1, M - 1
+            IE = 0
+            TMP1 = W( JE )
+            DO 140 J = JE + 1, M
+               IF( W( J ).LT.TMP1 ) THEN
+                  IE = J
+                  TMP1 = W( J )
+               END IF
+  140       CONTINUE
+*
+            IF( IE.NE.0 ) THEN
+               ITMP1 = IBLOCK( IE )
+               W( IE ) = W( JE )
+               IBLOCK( IE ) = IBLOCK( JE )
+               W( JE ) = TMP1
+               IBLOCK( JE ) = ITMP1
+            END IF
+  150    CONTINUE
+      END IF
+*
+      INFO = 0
+      IF( NCNVRG )
+     $   INFO = INFO + 1
+      IF( TOOFEW )
+     $   INFO = INFO + 2
+      RETURN
+*
+*     End of DSTEBZ
+*
+      END
diff --git a/SRC/dstedc.f b/SRC/dstedc.f
new file mode 100644
index 00000000..ad60e029
--- /dev/null
+++ b/SRC/dstedc.f
@@ -0,0 +1,407 @@
+      SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+     $                   LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPZ
+      INTEGER            INFO, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric tridiagonal matrix using the divide and conquer method.
+*  The eigenvectors of a full or band real symmetric matrix can also be
+*  found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
+*  matrix to tridiagonal form.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.  See DLAED3 for details.
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*          = 'V':  Compute eigenvectors of original dense symmetric
+*                  matrix also.  On entry, Z contains the orthogonal
+*                  matrix used to reduce the original matrix to
+*                  tridiagonal form.
+*
+*  N       (input) INTEGER
+*          The dimension of the symmetric tridiagonal 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 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.
+*          If eigenvectors are desired, then LDZ >= max(1,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.
+*          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1 then LWORK must be at least
+*                         ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
+*                         where lg( N ) = smallest integer k such
+*                         that 2**k >= N.
+*          If COMPZ = 'I' and N > 1 then LWORK must be at least
+*                         ( 1 + 4*N + N**2 ).
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LWORK need
+*          only be max(1,2*(N-1)).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  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.
+*          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1 then LIWORK must be at least
+*                         ( 6 + 6*N + 5*N*lg N ).
+*          If COMPZ = 'I' and N > 1 then LIWORK must be at least
+*                         ( 3 + 5*N ).
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LIWORK
+*          need only be 1.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
+     $                   LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
+      DOUBLE PRECISION   EPS, ORGNRM, P, TINY
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,
+     $                   DSTEQR, DSTERF, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG, MAX, MOD, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR.
+     $         ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Compute the workspace requirements
+*
+         SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
+         IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+         ELSE IF( N.LE.SMLSIZ ) THEN
+            LIWMIN = 1
+            LWMIN = 2*( N - 1 )
+         ELSE
+            LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) )
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            IF( ICOMPZ.EQ.1 ) THEN
+               LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
+               LIWMIN = 6 + 6*N + 5*N*LGN
+            ELSE IF( ICOMPZ.EQ.2 ) THEN
+               LWMIN = 1 + 4*N + N**2
+               LIWMIN = 3 + 5*N
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
+            INFO = -10
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEDC', -INFO )
+         RETURN
+      ELSE IF (LQUERY) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.NE.0 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     If the following conditional clause is removed, then the routine
+*     will use the Divide and Conquer routine to compute only the
+*     eigenvalues, which requires (3N + 3N**2) real workspace and
+*     (2 + 5N + 2N lg(N)) integer workspace.
+*     Since on many architectures DSTERF is much faster than any other
+*     algorithm for finding eigenvalues only, it is used here
+*     as the default. If the conditional clause is removed, then
+*     information on the size of workspace needs to be changed.
+*
+*     If COMPZ = 'N', use DSTERF to compute the eigenvalues.
+*
+      IF( ICOMPZ.EQ.0 ) THEN
+         CALL DSTERF( N, D, E, INFO )
+         GO TO 50
+      END IF
+*
+*     If N is smaller than the minimum divide size (SMLSIZ+1), then
+*     solve the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+*
+         CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+      ELSE
+*
+*        If COMPZ = 'V', the Z matrix must be stored elsewhere for later
+*        use.
+*
+         IF( ICOMPZ.EQ.1 ) THEN
+            STOREZ = 1 + N*N
+         ELSE
+            STOREZ = 1
+         END IF
+*
+         IF( ICOMPZ.EQ.2 ) THEN
+            CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+         END IF
+*
+*        Scale.
+*
+         ORGNRM = DLANST( 'M', N, D, E )
+         IF( ORGNRM.EQ.ZERO )
+     $      GO TO 50
+*
+         EPS = DLAMCH( 'Epsilon' )
+*
+         START = 1
+*
+*        while ( START <= N )
+*
+   10    CONTINUE
+         IF( START.LE.N ) THEN
+*
+*           Let FINISH be the position of the next subdiagonal entry
+*           such that E( FINISH ) <= TINY or FINISH = N if no such
+*           subdiagonal exists.  The matrix identified by the elements
+*           between START and FINISH constitutes an independent
+*           sub-problem.
+*
+            FINISH = START
+   20       CONTINUE
+            IF( FINISH.LT.N ) THEN
+               TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
+     $                    SQRT( ABS( D( FINISH+1 ) ) )
+               IF( ABS( E( FINISH ) ).GT.TINY ) THEN
+                  FINISH = FINISH + 1
+                  GO TO 20
+               END IF
+            END IF
+*
+*           (Sub) Problem determined.  Compute its size and solve it.
+*
+            M = FINISH - START + 1
+            IF( M.EQ.1 ) THEN
+               START = FINISH + 1
+               GO TO 10
+            END IF
+            IF( M.GT.SMLSIZ ) THEN
+*
+*              Scale.
+*
+               ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
+               CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
+     $                      INFO )
+               CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
+     $                      M-1, INFO )
+*
+               IF( ICOMPZ.EQ.1 ) THEN
+                  STRTRW = 1
+               ELSE
+                  STRTRW = START
+               END IF
+               CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),
+     $                      Z( STRTRW, START ), LDZ, WORK( 1 ), N,
+     $                      WORK( STOREZ ), IWORK, INFO )
+               IF( INFO.NE.0 ) THEN
+                  INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
+     $                   MOD( INFO, ( M+1 ) ) + START - 1
+                  GO TO 50
+               END IF
+*
+*              Scale back.
+*
+               CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
+     $                      INFO )
+*
+            ELSE
+               IF( ICOMPZ.EQ.1 ) THEN
+*
+*                 Since QR won't update a Z matrix which is larger than
+*                 the length of D, we must solve the sub-problem in a
+*                 workspace and then multiply back into Z.
+*
+                  CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,
+     $                         WORK( M*M+1 ), INFO )
+                  CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,
+     $                         WORK( STOREZ ), N )
+                  CALL DGEMM( 'N', 'N', N, M, M, ONE,
+     $                        WORK( STOREZ ), N, WORK, M, ZERO,
+     $                        Z( 1, START ), LDZ )
+               ELSE IF( ICOMPZ.EQ.2 ) THEN
+                  CALL DSTEQR( 'I', M, D( START ), E( START ),
+     $                         Z( START, START ), LDZ, WORK, INFO )
+               ELSE
+                  CALL DSTERF( M, D( START ), E( START ), INFO )
+               END IF
+               IF( INFO.NE.0 ) THEN
+                  INFO = START*( N+1 ) + FINISH
+                  GO TO 50
+               END IF
+            END IF
+*
+            START = FINISH + 1
+            GO TO 10
+         END IF
+*
+*        endwhile
+*
+*        If the problem split any number of times, then the eigenvalues
+*        will not be properly ordered.  Here we permute the eigenvalues
+*        (and the associated eigenvectors) into ascending order.
+*
+         IF( M.NE.N ) THEN
+            IF( ICOMPZ.EQ.0 ) THEN
+*
+*              Use Quick Sort
+*
+               CALL DLASRT( 'I', N, D, INFO )
+*
+            ELSE
+*
+*              Use Selection Sort to minimize swaps of eigenvectors
+*
+               DO 40 II = 2, N
+                  I = II - 1
+                  K = I
+                  P = D( I )
+                  DO 30 J = II, N
+                     IF( D( J ).LT.P ) THEN
+                        K = J
+                        P = D( J )
+                     END IF
+   30             CONTINUE
+                  IF( K.NE.I ) THEN
+                     D( K ) = D( I )
+                     D( I ) = P
+                     CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+                  END IF
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+   50 CONTINUE
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DSTEDC
+*
+      END
diff --git a/SRC/dstegr.f b/SRC/dstegr.f
new file mode 100644
index 00000000..baecd9b8
--- /dev/null
+++ b/SRC/dstegr.f
@@ -0,0 +1,180 @@
+      SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $           ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+     $           LIWORK, INFO )
+
+      IMPLICIT NONE
+*
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+      DOUBLE PRECISION ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
+      DOUBLE PRECISION   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEGR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  DSTEGR is a compatability wrapper around the improved DSTEMR routine.
+*  See DSTEMR for further details.
+*
+*  One important change is that the ABSTOL parameter no longer provides any
+*  benefit and hence is no longer used.
+*
+*  Note : DSTEGR and DSTEMR work only on machines which follow
+*  IEEE-754 floating-point standard in their handling of infinities and
+*  NaNs.  Normal execution may create these exceptiona values and hence
+*  may abort due to a floating point exception in environments which
+*  do not conform to the IEEE-754 standard.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          Unused.  Was the absolute error tolerance for the
+*          eigenvalues/eigenvectors in previous versions.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*          Supplying N columns is always safe.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in DLARRE,
+*                if INFO = 2X, internal error in DLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by DLARRE or
+*                DLARRV, respectively.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL TRYRAC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL DSTEMR
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+      TRYRAC = .FALSE.
+
+      CALL DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*     End of DSTEGR
+*
+      END
diff --git a/SRC/dstein.f b/SRC/dstein.f
new file mode 100644
index 00000000..a39a0f4c
--- /dev/null
+++ b/SRC/dstein.f
@@ -0,0 +1,361 @@
+      SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDZ, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
+     $                   IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEIN computes the eigenvectors of a real symmetric tridiagonal
+*  matrix T corresponding to specified eigenvalues, using inverse
+*  iteration.
+*
+*  The maximum number of iterations allowed for each eigenvector is
+*  specified by an internal parameter MAXITS (currently set to 5).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix
+*          T, in elements 1 to N-1.
+*
+*  M       (input) INTEGER
+*          The number of eigenvectors to be found.  0 <= M <= N.
+*
+*  W       (input) DOUBLE PRECISION array, dimension (N)
+*          The first M elements of W contain the eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block.  ( The output array
+*          W from DSTEBZ with ORDER = 'B' is expected here. )
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The submatrix indices associated with the corresponding
+*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
+*          the first submatrix from the top, =2 if W(i) belongs to
+*          the second submatrix, etc.  ( The output array IBLOCK
+*          from DSTEBZ is expected here. )
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*          ( The output array ISPLIT from DSTEBZ is expected here. )
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, M)
+*          The computed eigenvectors.  The eigenvector associated
+*          with the eigenvalue W(i) is stored in the i-th column of
+*          Z.  Any vector which fails to converge is set to its current
+*          iterate after MAXITS iterations.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  IFAIL   (output) INTEGER array, dimension (M)
+*          On normal exit, all elements of IFAIL are zero.
+*          If one or more eigenvectors fail to converge after
+*          MAXITS iterations, then their indices are stored in
+*          array IFAIL.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit.
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, then i eigenvectors failed to converge
+*               in MAXITS iterations.  Their indices are stored in
+*               array IFAIL.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXITS  INTEGER, default = 5
+*          The maximum number of iterations performed.
+*
+*  EXTRA   INTEGER, default = 2
+*          The number of iterations performed after norm growth
+*          criterion is satisfied, should be at least 1.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TEN, ODM3, ODM1
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
+     $                   ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
+      INTEGER            MAXITS, EXTRA
+      PARAMETER          ( MAXITS = 5, EXTRA = 2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
+     $                   INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
+     $                   JBLK, JMAX, NBLK, NRMCHK
+      DOUBLE PRECISION   DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
+     $                   SCL, SEP, TOL, XJ, XJM, ZTR
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 )
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DDOT, DLAMCH, DNRM2
+      EXTERNAL           IDAMAX, DASUM, DDOT, DLAMCH, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      DO 10 I = 1, M
+         IFAIL( I ) = 0
+   10 CONTINUE
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         DO 20 J = 2, M
+            IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
+               INFO = -6
+               GO TO 30
+            END IF
+            IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
+     $           THEN
+               INFO = -5
+               GO TO 30
+            END IF
+   20    CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      EPS = DLAMCH( 'Precision' )
+*
+*     Initialize seed for random number generator DLARNV.
+*
+      DO 40 I = 1, 4
+         ISEED( I ) = 1
+   40 CONTINUE
+*
+*     Initialize pointers.
+*
+      INDRV1 = 0
+      INDRV2 = INDRV1 + N
+      INDRV3 = INDRV2 + N
+      INDRV4 = INDRV3 + N
+      INDRV5 = INDRV4 + N
+*
+*     Compute eigenvectors of matrix blocks.
+*
+      J1 = 1
+      DO 160 NBLK = 1, IBLOCK( M )
+*
+*        Find starting and ending indices of block nblk.
+*
+         IF( NBLK.EQ.1 ) THEN
+            B1 = 1
+         ELSE
+            B1 = ISPLIT( NBLK-1 ) + 1
+         END IF
+         BN = ISPLIT( NBLK )
+         BLKSIZ = BN - B1 + 1
+         IF( BLKSIZ.EQ.1 )
+     $      GO TO 60
+         GPIND = B1
+*
+*        Compute reorthogonalization criterion and stopping criterion.
+*
+         ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
+         ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
+         DO 50 I = B1 + 1, BN - 1
+            ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
+     $               ABS( E( I ) ) )
+   50    CONTINUE
+         ORTOL = ODM3*ONENRM
+*
+         DTPCRT = SQRT( ODM1 / BLKSIZ )
+*
+*        Loop through eigenvalues of block nblk.
+*
+   60    CONTINUE
+         JBLK = 0
+         DO 150 J = J1, M
+            IF( IBLOCK( J ).NE.NBLK ) THEN
+               J1 = J
+               GO TO 160
+            END IF
+            JBLK = JBLK + 1
+            XJ = W( J )
+*
+*           Skip all the work if the block size is one.
+*
+            IF( BLKSIZ.EQ.1 ) THEN
+               WORK( INDRV1+1 ) = ONE
+               GO TO 120
+            END IF
+*
+*           If eigenvalues j and j-1 are too close, add a relatively
+*           small perturbation.
+*
+            IF( JBLK.GT.1 ) THEN
+               EPS1 = ABS( EPS*XJ )
+               PERTOL = TEN*EPS1
+               SEP = XJ - XJM
+               IF( SEP.LT.PERTOL )
+     $            XJ = XJM + PERTOL
+            END IF
+*
+            ITS = 0
+            NRMCHK = 0
+*
+*           Get random starting vector.
+*
+            CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
+*
+*           Copy the matrix T so it won't be destroyed in factorization.
+*
+            CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
+            CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
+            CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
+*
+*           Compute LU factors with partial pivoting  ( PT = LU )
+*
+            TOL = ZERO
+            CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
+     $                   IINFO )
+*
+*           Update iteration count.
+*
+   70       CONTINUE
+            ITS = ITS + 1
+            IF( ITS.GT.MAXITS )
+     $         GO TO 100
+*
+*           Normalize and scale the righthand side vector Pb.
+*
+            SCL = BLKSIZ*ONENRM*MAX( EPS,
+     $            ABS( WORK( INDRV4+BLKSIZ ) ) ) /
+     $            DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+*
+*           Solve the system LU = Pb.
+*
+            CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
+     $                   WORK( INDRV1+1 ), TOL, IINFO )
+*
+*           Reorthogonalize by modified Gram-Schmidt if eigenvalues are
+*           close enough.
+*
+            IF( JBLK.EQ.1 )
+     $         GO TO 90
+            IF( ABS( XJ-XJM ).GT.ORTOL )
+     $         GPIND = J
+            IF( GPIND.NE.J ) THEN
+               DO 80 I = GPIND, J - 1
+                  ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
+     $                  1 )
+                  CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1,
+     $                        WORK( INDRV1+1 ), 1 )
+   80          CONTINUE
+            END IF
+*
+*           Check the infinity norm of the iterate.
+*
+   90       CONTINUE
+            JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            NRM = ABS( WORK( INDRV1+JMAX ) )
+*
+*           Continue for additional iterations after norm reaches
+*           stopping criterion.
+*
+            IF( NRM.LT.DTPCRT )
+     $         GO TO 70
+            NRMCHK = NRMCHK + 1
+            IF( NRMCHK.LT.EXTRA+1 )
+     $         GO TO 70
+*
+            GO TO 110
+*
+*           If stopping criterion was not satisfied, update info and
+*           store eigenvector number in array ifail.
+*
+  100       CONTINUE
+            INFO = INFO + 1
+            IFAIL( INFO ) = J
+*
+*           Accept iterate as jth eigenvector.
+*
+  110       CONTINUE
+            SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            IF( WORK( INDRV1+JMAX ).LT.ZERO )
+     $         SCL = -SCL
+            CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+  120       CONTINUE
+            DO 130 I = 1, N
+               Z( I, J ) = ZERO
+  130       CONTINUE
+            DO 140 I = 1, BLKSIZ
+               Z( B1+I-1, J ) = WORK( INDRV1+I )
+  140       CONTINUE
+*
+*           Save the shift to check eigenvalue spacing at next
+*           iteration.
+*
+            XJM = XJ
+*
+  150    CONTINUE
+  160 CONTINUE
+*
+      RETURN
+*
+*     End of DSTEIN
+*
+      END
diff --git a/SRC/dstemr.f b/SRC/dstemr.f
new file mode 100644
index 00000000..f459ab71
--- /dev/null
+++ b/SRC/dstemr.f
@@ -0,0 +1,646 @@
+      SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      LOGICAL            TRYRAC
+      INTEGER            IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
+      DOUBLE PRECISION VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
+      DOUBLE PRECISION   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEMR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  Depending on the number of desired eigenvalues, these are computed either
+*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
+*  computed by the use of various suitable L D L^T factorizations near clusters
+*  of close eigenvalues (referred to as RRRs, Relatively Robust
+*  Representations). An informal sketch of the algorithm follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  For more details, see:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*  Notes:
+*  1.DSTEMR works only on machines which follow IEEE-754
+*  floating-point standard in their handling of infinities and NaNs.
+*  This permits the use of efficient inner loops avoiding a check for
+*  zero divisors.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and can be computed with a workspace
+*          query by setting NZC = -1, see below.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  NZC     (input) INTEGER
+*          The number of eigenvectors to be held in the array Z.
+*          If RANGE = 'A', then NZC >= max(1,N).
+*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+*          If RANGE = 'I', then NZC >= IU-IL+1.
+*          If NZC = -1, then a workspace query is assumed; the
+*          routine calculates the number of columns of the array Z that
+*          are needed to hold the eigenvectors.
+*          This value is returned as the first entry of the Z array, and
+*          no error message related to NZC is issued by XERBLA.
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  TRYRAC  (input/output) LOGICAL
+*          If TRYRAC.EQ..TRUE., indicates that the code should check whether
+*          the tridiagonal matrix defines its eigenvalues to high relative
+*          accuracy.  If so, the code uses relative-accuracy preserving
+*          algorithms that might be (a bit) slower depending on the matrix.
+*          If the matrix does not define its eigenvalues to high relative
+*          accuracy, the code can uses possibly faster algorithms.
+*          If TRYRAC.EQ..FALSE., the code is not required to guarantee
+*          relatively accurate eigenvalues and can use the fastest possible
+*          techniques.
+*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
+*          does not define its eigenvalues to high relative accuracy.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in DLARRE,
+*                if INFO = 2X, internal error in DLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by DLARRE or
+*                DLARRV, respectively.
+*
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, FOUR, MINRGP
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0,
+     $                     FOUR = 4.0D0,
+     $                     MINRGP = 1.0D-3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+      INTEGER            I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
+     $                   IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
+     $                   INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
+     $                   ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
+     $                   NZCMIN, OFFSET, WBEGIN, WEND
+      DOUBLE PRECISION   BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
+     $                   RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
+     $                   THRESH, TMP, TNRM, WL, WU
+*     ..
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ,
+     $                   DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+
+
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+      ZQUERY = ( NZC.EQ.-1 )
+
+*     DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
+*     In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
+*     Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N.
+      IF( WANTZ ) THEN
+         LWMIN = 18*N
+         LIWMIN = 10*N
+      ELSE
+*        need less workspace if only the eigenvalues are wanted
+         LWMIN = 12*N
+         LIWMIN = 8*N
+      ENDIF
+
+      WL = ZERO
+      WU = ZERO
+      IIL = 0
+      IIU = 0
+
+      IF( VALEIG ) THEN
+*        We do not reference VL, VU in the cases RANGE = 'I','A'
+*        The interval (WL, WU] contains all the wanted eigenvalues.
+*        It is either given by the user or computed in DLARRE.
+         WL = VL
+         WU = VU
+      ELSEIF( INDEIG ) THEN
+*        We do not reference IL, IU in the cases RANGE = 'V','A'
+         IIL = IL
+         IIU = IU
+      ENDIF
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
+         INFO = -7
+      ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
+         INFO = -8
+      ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -17
+      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -19
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( WANTZ .AND. ALLEIG ) THEN
+            NZCMIN = N
+         ELSE IF( WANTZ .AND. VALEIG ) THEN
+            CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+     $                            NZCMIN, ITMP, ITMP2, INFO )
+         ELSE IF( WANTZ .AND. INDEIG ) THEN
+            NZCMIN = IIU-IIL+1
+         ELSE
+*           WANTZ .EQ. FALSE.
+            NZCMIN = 0
+         ENDIF
+         IF( ZQUERY .AND. INFO.EQ.0 ) THEN
+            Z( 1,1 ) = NZCMIN
+         ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
+            INFO = -14
+         END IF
+      END IF
+
+      IF( INFO.NE.0 ) THEN
+*
+         CALL XERBLA( 'DSTEMR', -INFO )
+*
+         RETURN
+      ELSE IF( LQUERY .OR. ZQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Handle N = 0, 1, and 2 cases immediately
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            Z( 1, 1 ) = ONE
+            ISUPPZ(1) = 1
+            ISUPPZ(2) = 1
+         END IF
+         RETURN
+      END IF
+*
+      IF( N.EQ.2 ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL DLAE2( D(1), E(1), D(2), R1, R2 )
+         ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
+         END IF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R2.GT.WL).AND.
+     $                  (R2.LE.WU)).OR.
+     $      (INDEIG.AND.(IIL.EQ.1)) ) THEN
+            M = M+1
+            W( M ) = R2
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = -SN
+               Z( 2, M ) = CS
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R1.GT.WL).AND.
+     $                  (R1.LE.WU)).OR.
+     $      (INDEIG.AND.(IIU.EQ.2)) ) THEN
+            M = M+1
+            W( M ) = R1
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = CS
+               Z( 2, M ) = SN
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         RETURN
+      END IF
+
+*     Continue with general N
+
+      INDGRS = 1
+      INDERR = 2*N + 1
+      INDGP = 3*N + 1
+      INDD = 4*N + 1
+      INDE2 = 5*N + 1
+      INDWRK = 6*N + 1
+*
+      IINSPL = 1
+      IINDBL = N + 1
+      IINDW = 2*N + 1
+      IINDWK = 3*N + 1
+*
+*     Scale matrix to allowable range, if necessary.
+*     The allowable range is related to the PIVMIN parameter; see the
+*     comments in DLARRD.  The preference for scaling small values
+*     up is heuristic; we expect users' matrices not to be close to the
+*     RMAX threshold.
+*
+      SCALE = ONE
+      TNRM = DLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         SCALE = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         SCALE = RMAX / TNRM
+      END IF
+      IF( SCALE.NE.ONE ) THEN
+         CALL DSCAL( N, SCALE, D, 1 )
+         CALL DSCAL( N-1, SCALE, E, 1 )
+         TNRM = TNRM*SCALE
+         IF( VALEIG ) THEN
+*           If eigenvalues in interval have to be found,
+*           scale (WL, WU] accordingly
+            WL = WL*SCALE
+            WU = WU*SCALE
+         ENDIF
+      END IF
+*
+*     Compute the desired eigenvalues of the tridiagonal after splitting
+*     into smaller subblocks if the corresponding off-diagonal elements
+*     are small
+*     THRESH is the splitting parameter for DLARRE
+*     A negative THRESH forces the old splitting criterion based on the
+*     size of the off-diagonal. A positive THRESH switches to splitting
+*     which preserves relative accuracy.
+*
+      IF( TRYRAC ) THEN
+*        Test whether the matrix warrants the more expensive relative approach.
+         CALL DLARRR( N, D, E, IINFO )
+      ELSE
+*        The user does not care about relative accurately eigenvalues
+         IINFO = -1
+      ENDIF
+*     Set the splitting criterion
+      IF (IINFO.EQ.0) THEN
+         THRESH = EPS
+      ELSE
+         THRESH = -EPS
+*        relative accuracy is desired but T does not guarantee it
+         TRYRAC = .FALSE.
+      ENDIF
+*
+      IF( TRYRAC ) THEN
+*        Copy original diagonal, needed to guarantee relative accuracy
+         CALL DCOPY(N,D,1,WORK(INDD),1)
+      ENDIF
+*     Store the squares of the offdiagonal values of T
+      DO 5 J = 1, N-1
+         WORK( INDE2+J-1 ) = E(J)**2
+ 5    CONTINUE
+
+*     Set the tolerance parameters for bisection
+      IF( .NOT.WANTZ ) THEN
+*        DLARRE computes the eigenvalues to full precision.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ELSE
+*        DLARRE computes the eigenvalues to less than full precision.
+*        DLARRV will refine the eigenvalue approximations, and we can
+*        need less accurate initial bisection in DLARRE.
+*        Note: these settings do only affect the subset case and DLARRE
+         RTOL1 = SQRT(EPS)
+         RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
+      ENDIF
+      CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
+     $             WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+     $             IWORK( IINSPL ), M, W, WORK( INDERR ),
+     $             WORK( INDGP ), IWORK( IINDBL ),
+     $             IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+     $             WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = 10 + ABS( IINFO )
+         RETURN
+      END IF
+*     Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
+*     part of the spectrum. All desired eigenvalues are contained in
+*     (WL,WU]
+
+
+      IF( WANTZ ) THEN
+*
+*        Compute the desired eigenvectors corresponding to the computed
+*        eigenvalues
+*
+         CALL DLARRV( N, WL, WU, D, E,
+     $                PIVMIN, IWORK( IINSPL ), M,
+     $                1, M, MINRGP, RTOL1, RTOL2,
+     $                W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+     $                IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
+     $                ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = 20 + ABS( IINFO )
+            RETURN
+         END IF
+      ELSE
+*        DLARRE computes eigenvalues of the (shifted) root representation
+*        DLARRV returns the eigenvalues of the unshifted matrix.
+*        However, if the eigenvectors are not desired by the user, we need
+*        to apply the corresponding shifts from DLARRE to obtain the
+*        eigenvalues of the original matrix.
+         DO 20 J = 1, M
+            ITMP = IWORK( IINDBL+J-1 )
+            W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 20      CONTINUE
+      END IF
+*
+
+      IF ( TRYRAC ) THEN
+*        Refine computed eigenvalues so that they are relatively accurate
+*        with respect to the original matrix T.
+         IBEGIN = 1
+         WBEGIN = 1
+         DO 39  JBLK = 1, IWORK( IINDBL+M-1 )
+            IEND = IWORK( IINSPL+JBLK-1 )
+            IN = IEND - IBEGIN + 1
+            WEND = WBEGIN - 1
+*           check if any eigenvalues have to be refined in this block
+ 36         CONTINUE
+            IF( WEND.LT.M ) THEN
+               IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
+                  WEND = WEND + 1
+                  GO TO 36
+               END IF
+            END IF
+            IF( WEND.LT.WBEGIN ) THEN
+               IBEGIN = IEND + 1
+               GO TO 39
+            END IF
+
+            OFFSET = IWORK(IINDW+WBEGIN-1)-1
+            IFIRST = IWORK(IINDW+WBEGIN-1)
+            ILAST = IWORK(IINDW+WEND-1)
+            RTOL2 = FOUR * EPS
+            CALL DLARRJ( IN,
+     $                   WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
+     $                   IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
+     $                   WORK( INDERR+WBEGIN-1 ),
+     $                   WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
+     $                   TNRM, IINFO )
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+ 39      CONTINUE
+      ENDIF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( SCALE.NE.ONE ) THEN
+         CALL DSCAL( M, ONE / SCALE, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in increasing order, then sort them,
+*     possibly along with eigenvectors.
+*
+      IF( NSPLIT.GT.1 ) THEN
+         IF( .NOT. WANTZ ) THEN
+            CALL DLASRT( 'I', M, W, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = 3
+               RETURN
+            END IF
+         ELSE
+            DO 60 J = 1, M - 1
+               I = 0
+               TMP = W( J )
+               DO 50 JJ = J + 1, M
+                  IF( W( JJ ).LT.TMP ) THEN
+                     I = JJ
+                     TMP = W( JJ )
+                  END IF
+ 50            CONTINUE
+               IF( I.NE.0 ) THEN
+                  W( I ) = W( J )
+                  W( J ) = TMP
+                  IF( WANTZ ) THEN
+                     CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+                     ITMP = ISUPPZ( 2*I-1 )
+                     ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
+                     ISUPPZ( 2*J-1 ) = ITMP
+                     ITMP = ISUPPZ( 2*I )
+                     ISUPPZ( 2*I ) = ISUPPZ( 2*J )
+                     ISUPPZ( 2*J ) = ITMP
+                  END IF
+               END IF
+ 60         CONTINUE
+         END IF
+      ENDIF
+*
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of DSTEMR
+*
+      END
diff --git a/SRC/dsteqr.f b/SRC/dsteqr.f
new file mode 100644
index 00000000..0afd7957
--- /dev/null
+++ b/SRC/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/dsterf.f b/SRC/dsterf.f
new file mode 100644
index 00000000..c17ea23a
--- /dev/null
+++ b/SRC/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/dstev.f b/SRC/dstev.f
new file mode 100644
index 00000000..9c1132f3
--- /dev/null
+++ b/SRC/dstev.f
@@ -0,0 +1,163 @@
+      SUBROUTINE DSTEV( JOBZ, N, D, E, 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
+      INTEGER            INFO, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEV computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric tridiagonal matrix A.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          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 A, stored in elements 1 to N-1 of E.
+*          On exit, the contents of E are destroyed.
+*
+*  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 D(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 (max(1,2*N-2))
+*          If JOBZ = 'N', WORK is not referenced.
+*
+*  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 E did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTZ
+      INTEGER            IMAX, ISCALE
+      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TNRM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTEQR, DSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      TNRM = DLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( N, SIGMA, D, 1 )
+         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+      END IF
+*
+*     For eigenvalues only, call DSTERF.  For eigenvalues and
+*     eigenvectors, call DSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, D, E, INFO )
+      ELSE
+         CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, D, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of DSTEV
+*
+      END
diff --git a/SRC/dstevd.f b/SRC/dstevd.f
new file mode 100644
index 00000000..949ded88
--- /dev/null
+++ b/SRC/dstevd.f
@@ -0,0 +1,219 @@
+      SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+     $                   LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ
+      INTEGER            INFO, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEVD computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric tridiagonal matrix. If eigenvectors are desired, it
+*  uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          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 A, stored in elements 1 to N-1 of E.
+*          On exit, the contents of E are destroyed.
+*
+*  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 D(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/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.
+*          If JOBZ  = 'N' or N <= 1 then LWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1 then LWORK must be at least
+*                         ( 1 + 4*N + N**2 ).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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.
+*          If JOBZ  = 'N' or N <= 1 then LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1 then LIWORK must be at least 3+5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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 E did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTZ
+      INTEGER            ISCALE, LIWMIN, LWMIN
+      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TNRM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTEDC, DSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      LIWMIN = 1
+      LWMIN = 1
+      IF( N.GT.1 .AND. WANTZ ) THEN
+         LWMIN = 1 + 4*N + N**2
+         LIWMIN = 3 + 5*N
+      END IF
+*
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      TNRM = DLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( N, SIGMA, D, 1 )
+         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+      END IF
+*
+*     For eigenvalues only, call DSTERF.  For eigenvalues and
+*     eigenvectors, call DSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, D, E, INFO )
+      ELSE
+         CALL DSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK,
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL DSCAL( N, ONE / SIGMA, D, 1 )
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DSTEVD
+*
+      END
diff --git a/SRC/dstevr.f b/SRC/dstevr.f
new file mode 100644
index 00000000..6a161ebc
--- /dev/null
+++ b/SRC/dstevr.f
@@ -0,0 +1,462 @@
+      SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+     $                   M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+     $                   LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEVR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T.  Eigenvalues and
+*  eigenvectors can be selected by specifying either a range of values
+*  or a range of indices for the desired eigenvalues.
+*
+*  Whenever possible, DSTEVR calls DSTEMR to compute the
+*  eigenspectrum using Relatively Robust Representations.  DSTEMR
+*  computes eigenvalues by the dqds algorithm, while orthogonal
+*  eigenvectors are computed from various "good" L D L^T representations
+*  (also known as Relatively Robust Representations). Gram-Schmidt
+*  orthogonalization is avoided as far as possible. More specifically,
+*  the various steps of the algorithm are as follows. For the i-th
+*  unreduced block of T,
+*     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
+*          is a relatively robust representation,
+*     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
+*         relative accuracy by the dqds algorithm,
+*     (c) If there is a cluster of close eigenvalues, "choose" sigma_i
+*         close to the cluster, and go to step (a),
+*     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
+*         compute the corresponding eigenvector by forming a
+*         rank-revealing twisted factorization.
+*  The desired accuracy of the output can be specified by the input
+*  parameter ABSTOL.
+*
+*  For more details, see "A new O(n^2) algorithm for the symmetric
+*  tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
+*  Computer Science Division Technical Report No. UCB//CSD-97-971,
+*  UC Berkeley, May 1997.
+*
+*
+*  Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested
+*  on machines which conform to the ieee-754 floating point standard.
+*  DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and
+*  when partial spectrum requests are made.
+*
+*  Normal execution of DSTEMR may create NaNs and infinities and
+*  hence may abort due to a floating point exception in environments
+*  which do not handle NaNs and infinities in the ieee standard default
+*  manner.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
+********** DSTEIN are called
+*
+*  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
+*          A.
+*          On exit, D may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A in elements 1 to N-1 of E.
+*          On exit, E may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*          If high relative accuracy is important, set ABSTOL to
+*          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that
+*          eigenvalues are computed to high relative accuracy when
+*          possible in future releases.  The current code does not
+*          make any guarantees about high relative accuracy, but
+*          future releases will. See J. Barlow and J. Demmel,
+*          "Computing Accurate Eigensystems of Scaled Diagonally
+*          Dominant Matrices", LAPACK Working Note #7, for a discussion
+*          of which matrices define their eigenvalues to high relative
+*          accuracy.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal (and
+*          minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,20*N).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal (and
+*          minimal) LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  Internal error
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Ken Stanley, Computer Science Division, University of
+*       California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ,
+     $                   TRYRAC
+      CHARACTER          ORDER
+      INTEGER            I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP,
+     $                   INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN,
+     $                   NSPLIT
+      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TMP1, TNRM, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, DSTERF,
+     $                   DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*
+*     Test the input parameters.
+*
+      IEEEOK = ILAENV( 10, 'DSTEVR', 'N', 1, 2, 3, 4 )
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+      LWMIN = MAX( 1, 20*N )
+      LIWMIN = MAX( 1, 10*N )
+*
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -14
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -17
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -19
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEVR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      VLL = VL
+      VUU = VU
+*
+      TNRM = DLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( N, SIGMA, D, 1 )
+         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+
+*     Initialize indices into workspaces.  Note: These indices are used only
+*     if DSTERF or DSTEMR fail.
+
+*     IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
+*     stores the block indices of each of the M<=N eigenvalues.
+      INDIBL = 1
+*     IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
+*     stores the starting and finishing indices of each block.
+      INDISP = INDIBL + N
+*     IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+*     that corresponding to eigenvectors that fail to converge in
+*     DSTEIN.  This information is discarded; if any fail, the driver
+*     returns INFO > 0.
+      INDIFL = INDISP + N
+*     INDIWO is the offset of the remaining integer workspace.
+      INDIWO = INDISP + N
+*
+*     If all eigenvalues are desired, then
+*     call DSTERF or DSTEMR.  If this fails for some eigenvalue, then
+*     try DSTEBZ.
+*
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN
+         CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N, D, 1, W, 1 )
+            CALL DSTERF( N, W, WORK, INFO )
+         ELSE
+            CALL DCOPY( N, D, 1, WORK( N+1 ), 1 )
+            IF (ABSTOL .LE. TWO*N*EPS) THEN
+               TRYRAC = .TRUE.
+            ELSE
+               TRYRAC = .FALSE.
+            END IF
+            CALL DSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL,
+     $                   IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC,
+     $                   WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
+*
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 10
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+     $             NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK,
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+     $                Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ),
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   10 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 30 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 20 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   20       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( I )
+               W( I ) = W( J )
+               IWORK( I ) = IWORK( J )
+               W( J ) = TMP1
+               IWORK( J ) = ITMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+            END IF
+   30    CONTINUE
+      END IF
+*
+*      Causes problems with tests 19 & 20:
+*      IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
+*
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of DSTEVR
+*
+      END
diff --git a/SRC/dstevx.f b/SRC/dstevx.f
new file mode 100644
index 00000000..8c36122e
--- /dev/null
+++ b/SRC/dstevx.f
@@ -0,0 +1,350 @@
+      SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+     $                   M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix A.  Eigenvalues and
+*  eigenvectors can be selected by specifying either a range of values
+*  or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          On exit, D may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A in elements 1 to N-1 of E.
+*          On exit, E may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less
+*          than or equal to zero, then  EPS*|T|  will be used in
+*          its place, where |T| is the 1-norm of the tridiagonal
+*          matrix.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge (INFO > 0), then that
+*          column of Z contains the latest approximation to the
+*          eigenvector, and the index of the eigenvector is returned
+*          in IFAIL.  If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  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 (5*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
+     $                   ISCALE, ITMP1, J, JJ, NSPLIT
+      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TMP1, TNRM, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF,
+     $                   DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -14
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      END IF
+      TNRM = DLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( N, SIGMA, D, 1 )
+         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     If all eigenvalues are desired and ABSTOL is less than zero, then
+*     call DSTERF or SSTEQR.  If this fails for some eigenvalue, then
+*     try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL DCOPY( N, D, 1, W, 1 )
+         CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+         INDWRK = N + 1
+         IF( .NOT.WANTZ ) THEN
+            CALL DSTERF( N, W, WORK, INFO )
+         ELSE
+            CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 20
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDWRK = 1
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+     $             NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
+     $             WORK( INDWRK ), IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+     $                Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   20 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 40 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 30 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   30       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSTEVX
+*
+      END
diff --git a/SRC/dsycon.f b/SRC/dsycon.f
new file mode 100644
index 00000000..711b48ca
--- /dev/null
+++ b/SRC/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/dsyev.f b/SRC/dsyev.f
new file mode 100644
index 00000000..d73600a2
--- /dev/null
+++ b/SRC/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/dsyevd.f b/SRC/dsyevd.f
new file mode 100644
index 00000000..4c7ff8dc
--- /dev/null
+++ b/SRC/dsyevd.f
@@ -0,0 +1,275 @@
+      SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
+     $                   LIWORK, 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, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric matrix A. If eigenvectors are desired, it uses a
+*  divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Because of large use of BLAS of level 3, DSYEVD needs N**2 more
+*  workspace than DSYEVX.
+*
+*  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 (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least
+*                                                1 + 6*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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.
+*          If N <= 1,                LIWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i and JOBZ = 'N', then the algorithm failed
+*                to converge; i off-diagonal elements of an intermediate
+*                tridiagonal form did not converge to zero;
+*                if INFO = i and JOBZ = 'V', then the algorithm failed
+*                to compute an eigenvalue while working on the submatrix
+*                lying in rows and columns INFO/(N+1) through
+*                mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  Modified description of INFO. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+*
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
+     $                   LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANSY
+      EXTERNAL           LSAME, DLAMCH, DLANSY, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF,
+     $                   DSYTRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+            LOPT = LWMIN
+            LIOPT = LIWMIN
+         ELSE
+            IF( WANTZ ) THEN
+               LIWMIN = 3 + 5*N
+               LWMIN = 1 + 6*N + 2*N**2
+            ELSE
+               LIWMIN = 1
+               LWMIN = 2*N + 1
+            END IF
+            LOPT = MAX( LWMIN, 2*N +
+     $                  ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
+            LIOPT = LIWMIN
+         END IF
+         WORK( 1 ) = LOPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = A( 1, 1 )
+         IF( WANTZ )
+     $      A( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 )
+     $   CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      INDWK2 = INDWRK + N*N
+      LLWRK2 = LWORK - INDWK2 + 1
+*
+      CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+      LOPT = 2*N + WORK( INDWRK )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+*     tridiagonal matrix, then call DORMTR to multiply it by the
+*     Householder transformations stored in A.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+         CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
+     $                WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
+         CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
+         LOPT = MAX( LOPT, 1+6*N+2*N**2 )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL DSCAL( N, ONE / SIGMA, W, 1 )
+*
+      WORK( 1 ) = LOPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of DSYEVD
+*
+      END
diff --git a/SRC/dsyevr.f b/SRC/dsyevr.f
new file mode 100644
index 00000000..c213c998
--- /dev/null
+++ b/SRC/dsyevr.f
@@ -0,0 +1,551 @@
+      SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYEVR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be
+*  selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  DSYEVR first reduces the matrix A to tridiagonal form T with a call
+*  to DSYTRD.  Then, whenever possible, DSYEVR calls DSTEMR to compute
+*  the eigenspectrum using Relatively Robust Representations.  DSTEMR
+*  computes eigenvalues by the dqds algorithm, while orthogonal
+*  eigenvectors are computed from various "good" L D L^T representations
+*  (also known as Relatively Robust Representations). Gram-Schmidt
+*  orthogonalization is avoided as far as possible. More specifically,
+*  the various steps of the algorithm are as follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  The desired accuracy of the output can be specified by the input
+*  parameter ABSTOL.
+*
+*  For more details, see DSTEMR's documentation and:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*
+*  Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
+*  on machines which conform to the ieee-754 floating point standard.
+*  DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
+*  when partial spectrum requests are made.
+*
+*  Normal execution of DSTEMR may create NaNs and infinities and
+*  hence may abort due to a floating point exception in environments
+*  which do not handle NaNs and infinities in the ieee standard default
+*  manner.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
+********** DSTEIN are called
+*
+*  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, 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).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*          If high relative accuracy is important, set ABSTOL to
+*          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that
+*          eigenvalues are computed to high relative accuracy when
+*          possible in future releases.  The current code does not
+*          make any guarantees about high relative accuracy, but
+*          future releases will. See J. Barlow and J. Demmel,
+*          "Computing Accurate Eigensystems of Scaled Diagonally
+*          Dominant Matrices", LAPACK Working Note #7, for a discussion
+*          of which matrices define their eigenvalues to high relative
+*          accuracy.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*          Supplying N columns is always safe.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 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 >= max(1,26*N).
+*          For optimal efficiency, LWORK >= (NB+6)*N,
+*          where NB is the max of the blocksize for DSYTRD and DORMTR
+*          returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  Internal error
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Ken Stanley, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Jason Riedy, Computer Science Division, University of
+*       California at Berkeley, USA
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ,
+     $                   TRYRAC
+      CHARACTER          ORDER
+      INTEGER            I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
+     $                   INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
+     $                   INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
+     $                   LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANSY
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN,
+     $                   DSTERF, DSWAP, DSYTRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 )
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+*
+      LWMIN = MAX( 1, 26*N )
+      LIWMIN = MAX( 1, 10*N )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+         NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
+         LWKOPT = MAX( ( NB+1 )*N, LWMIN )
+         WORK( 1 ) = LWKOPT
+         IWORK( 1 ) = LIWMIN
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYEVR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         WORK( 1 ) = 7
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = A( 1, 1 )
+         ELSE
+            IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+               M = 1
+               W( 1 ) = A( 1, 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      VLL = VL
+      VUU = VU
+      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+
+*     Initialize indices into workspaces.  Note: The IWORK indices are
+*     used only if DSTERF or DSTEMR fail.
+
+*     WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
+*     elementary reflectors used in DSYTRD.
+      INDTAU = 1
+*     WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
+      INDD = INDTAU + N
+*     WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
+*     tridiagonal matrix from DSYTRD.
+      INDE = INDD + N
+*     WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
+*     -written by DSTEMR (the DSTERF path copies the diagonal to W).
+      INDDD = INDE + N
+*     WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
+*     -written while computing the eigenvalues in DSTERF and DSTEMR.
+      INDEE = INDDD + N
+*     INDWK is the starting offset of the left-over workspace, and
+*     LLWORK is the remaining workspace size.
+      INDWK = INDEE + N
+      LLWORK = LWORK - INDWK + 1
+
+*     IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
+*     stores the block indices of each of the M<=N eigenvalues.
+      INDIBL = 1
+*     IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
+*     stores the starting and finishing indices of each block.
+      INDISP = INDIBL + N
+*     IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+*     that corresponding to eigenvectors that fail to converge in
+*     DSTEIN.  This information is discarded; if any fail, the driver
+*     returns INFO > 0.
+      INDIFL = INDISP + N
+*     INDIWO is the offset of the remaining integer workspace.
+      INDIWO = INDISP + N
+
+*
+*     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+     $             WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired
+*     then call DSTERF or DSTEMR and DORMTR.
+*
+      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND.
+     $    IEEEOK.EQ.1 ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
+*
+            IF (ABSTOL .LE. TWO*N*EPS) THEN
+               TRYRAC = .TRUE.
+            ELSE
+               TRYRAC = .FALSE.
+            END IF
+            CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
+     $                   VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
+     $                   TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
+     $                   INFO )
+*
+*
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by DSTEIN.
+*
+            IF( WANTZ .AND. INFO.EQ.0 ) THEN
+               INDWKN = INDE
+               LLWRKN = LWORK - INDWKN + 1
+               CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA,
+     $                      WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
+     $                      LLWRKN, IINFO )
+            END IF
+         END IF
+*
+*
+         IF( INFO.EQ.0 ) THEN
+*           Everything worked.  Skip DSTEBZ/DSTEIN.  IWORK(:) are
+*           undefined.
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
+*     Also call DSTEBZ and DSTEIN if DSTEMR fails.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
+     $                INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by DSTEIN.
+*
+         INDWKN = INDE
+         LLWRKN = LWORK - INDWKN + 1
+         CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+*  Jump here if DSTEMR/DSTEIN succeeded.
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.  Note: We do not sort the IFAIL portion of IWORK.
+*     It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
+*     not return this detailed information to the user.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               W( I ) = W( J )
+               W( J ) = TMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+            END IF
+   50    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DSYEVR
+*
+      END
diff --git a/SRC/dsyevx.f b/SRC/dsyevx.f
new file mode 100644
index 00000000..8ea48b21
--- /dev/null
+++ b/SRC/dsyevx.f
@@ -0,0 +1,433 @@
+      SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LWORK, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be
+*  selected by specifying either a range of values or a range of indices
+*  for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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, 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).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= 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 the array WORK.  LWORK >= 1, when N <= 1;
+*          otherwise 8*N.
+*          For optimal efficiency, LWORK >= (NB+3)*N,
+*          where NB is the max of the blocksize for DSYTRD and DORMTR
+*          returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
+     $                   ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
+     $                   LWKOPT, NB, NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANSY
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ,
+     $                   DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWKMIN = 1
+            WORK( 1 ) = LWKMIN
+         ELSE
+            LWKMIN = 8*N
+            NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+            NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
+            LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+            WORK( 1 ) = LWKOPT
+         END IF
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+     $      INFO = -17
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = A( 1, 1 )
+         ELSE
+            IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+               M = 1
+               W( 1 ) = A( 1, 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      INDTAU = 1
+      INDE = INDTAU + N
+      INDD = INDE + N
+      INDWRK = INDD + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+     $             WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal to
+*     zero, then call DSTERF or DORGTR and SSTEQR.  If this fails for
+*     some eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ )
+            CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
+     $                   WORK( INDWRK ), LLWORK, IINFO )
+            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 30 I = 1, N
+                  IFAIL( I ) = 0
+   30          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 40
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by DSTEIN.
+*
+         INDWKN = INDE
+         LLWRKN = LWORK - INDWKN + 1
+         CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   40 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 60 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 50 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   50       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   60    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DSYEVX
+*
+      END
diff --git a/SRC/dsygs2.f b/SRC/dsygs2.f
new file mode 100644
index 00000000..2bdc4752
--- /dev/null
+++ b/SRC/dsygs2.f
@@ -0,0 +1,211 @@
+      SUBROUTINE DSYGS2( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYGS2 reduces a real symmetric-definite generalized eigenproblem
+*  to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
+*
+*  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` or L'*A*L.
+*
+*  B must have been previously factorized as U'*U or L*L' by DPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
+*          = 2 or 3: compute U*A*U' or L'*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored, and how B has been factorized.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  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 symmetric matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by DPOTRF.
+*
+*  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, HALF
+      PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K
+      DOUBLE PRECISION   AKK, BKK, CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYGS2', -INFO )
+         RETURN
+      END IF
+*
+      IF( ITYPE.EQ.1 ) THEN
+         IF( UPPER ) THEN
+*
+*           Compute inv(U')*A*inv(U)
+*
+            DO 10 K = 1, N
+*
+*              Update the upper triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
+                  CT = -HALF*AKK
+                  CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
+     $                        B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
+                  CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K,
+     $                        B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute inv(L)*A*inv(L')
+*
+            DO 20 K = 1, N
+*
+*              Update the lower triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
+                  CT = -HALF*AKK
+                  CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
+     $                        B( K+1, K ), 1, A( K+1, K+1 ), LDA )
+                  CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
+     $                        B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
+               END IF
+   20       CONTINUE
+         END IF
+      ELSE
+         IF( UPPER ) THEN
+*
+*           Compute U*A*U'
+*
+            DO 30 K = 1, N
+*
+*              Update the upper triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
+     $                     LDB, A( 1, K ), 1 )
+               CT = HALF*AKK
+               CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
+     $                     A, LDA )
+               CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL DSCAL( K-1, BKK, A( 1, K ), 1 )
+               A( K, K ) = AKK*BKK**2
+   30       CONTINUE
+         ELSE
+*
+*           Compute L'*A*L
+*
+            DO 40 K = 1, N
+*
+*              Update the lower triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
+     $                     A( K, 1 ), LDA )
+               CT = HALF*AKK
+               CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
+     $                     LDB, A, LDA )
+               CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL DSCAL( K-1, BKK, A( K, 1 ), LDA )
+               A( K, K ) = AKK*BKK**2
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of DSYGS2
+*
+      END
diff --git a/SRC/dsygst.f b/SRC/dsygst.f
new file mode 100644
index 00000000..093c7931
--- /dev/null
+++ b/SRC/dsygst.f
@@ -0,0 +1,249 @@
+      SUBROUTINE DSYGST( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYGST reduces a real symmetric-definite generalized eigenproblem
+*  to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+*  B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
+*
+*  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.
+*
+*  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 transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by DPOTRF.
+*
+*  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, HALF
+      PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ITYPE.EQ.1 ) THEN
+            IF( UPPER ) THEN
+*
+*              Compute inv(U')*A*inv(U)
+*
+               DO 10 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(k:n,k:n)
+*
+                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
+     $                           KB, N-K-KB+1, ONE, B( K, K ), LDB,
+     $                           A( K, K+KB ), LDA )
+                     CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+     $                           A( K, K+KB ), LDA )
+                     CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
+     $                            A( K, K+KB ), LDA, B( K, K+KB ), LDB,
+     $                            ONE, A( K+KB, K+KB ), LDA )
+                     CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+     $                           A( K, K+KB ), LDA )
+                     CALL DTRSM( 'Right', UPLO, 'No transpose',
+     $                           'Non-unit', KB, N-K-KB+1, ONE,
+     $                           B( K+KB, K+KB ), LDB, A( K, K+KB ),
+     $                           LDA )
+                  END IF
+   10          CONTINUE
+            ELSE
+*
+*              Compute inv(L)*A*inv(L')
+*
+               DO 20 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(k:n,k:n)
+*
+                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
+     $                           N-K-KB+1, KB, ONE, B( K, K ), LDB,
+     $                           A( K+KB, K ), LDA )
+                     CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+     $                           A( K+KB, K ), LDA )
+                     CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
+     $                            -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
+     $                            LDB, ONE, A( K+KB, K+KB ), LDA )
+                     CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+     $                           A( K+KB, K ), LDA )
+                     CALL DTRSM( 'Left', UPLO, 'No transpose',
+     $                           'Non-unit', N-K-KB+1, KB, ONE,
+     $                           B( K+KB, K+KB ), LDB, A( K+KB, K ),
+     $                           LDA )
+                  END IF
+   20          CONTINUE
+            END IF
+         ELSE
+            IF( UPPER ) THEN
+*
+*              Compute U*A*U'
+*
+               DO 30 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
+     $                        K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
+                  CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+                  CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
+     $                         A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
+     $                         LDA )
+                  CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+                  CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
+     $                        K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
+     $                        LDA )
+                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   30          CONTINUE
+            ELSE
+*
+*              Compute L'*A*L
+*
+               DO 40 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
+     $                        KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
+                  CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+                  CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
+     $                         A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
+     $                         LDA )
+                  CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+                  CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
+     $                        K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
+                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      RETURN
+*
+*     End of DSYGST
+*
+      END
diff --git a/SRC/dsygv.f b/SRC/dsygv.f
new file mode 100644
index 00000000..9ae8b73e
--- /dev/null
+++ b/SRC/dsygv.f
@@ -0,0 +1,229 @@
+      SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, 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, ITYPE, LDA, LDB, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.
+*  Here A and B are assumed to be symmetric and B is also
+*  positive definite.
+*
+*  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.
+*
+*  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
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  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 symmetric positive definite matrix B.
+*          If UPLO = 'U', the leading N-by-N upper triangular part of B
+*          contains the upper triangular part of the matrix B.
+*          If UPLO = 'L', the leading N-by-N lower triangular part of B
+*          contains the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= 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:  DPOTRF or DSYEV returned an error code:
+*             <= N:  if INFO = i, DSYEV failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKMIN, LWKOPT, NB, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKMIN = MAX( 1, 3*N - 1 )
+         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYGV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL DPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DSYGV
+*
+      END
diff --git a/SRC/dsygvd.f b/SRC/dsygvd.f
new file mode 100644
index 00000000..34c50068
--- /dev/null
+++ b/SRC/dsygvd.f
@@ -0,0 +1,282 @@
+      SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+     $                   LWORK, IWORK, LIWORK, 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, LDA, LDB, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
+*  B are assumed to be symmetric and B is also positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  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
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  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 symmetric matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= 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 dimension of the array WORK.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
+*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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.
+*          If N <= 1,                LIWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  DPOTRF or DSYEVD returned an error code:
+*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm
+*                    failed to converge; i off-diagonal elements of an
+*                    intermediate tridiagonal form did not converge to
+*                    zero;
+*                    if INFO = i and JOBZ = 'V', then the algorithm
+*                    failed to compute an eigenvalue while working on
+*                    the submatrix lying in rows and columns INFO/(N+1)
+*                    through mod(INFO,N+1);
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  Modified so that no backsubstitution is performed if DSYEVD fails to
+*  converge (NEIG in old code could be greater than N causing out of
+*  bounds reference to A - reported by Ralf Meyer).  Also corrected the
+*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LIOPT, LIWMIN, LOPT, LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LIWMIN = 1
+         LWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LIWMIN = 3 + 5*N
+         LWMIN = 1 + 6*N + 2*N**2
+      ELSE
+         LIWMIN = 1
+         LWMIN = 2*N + 1
+      END IF
+      LOPT = LWMIN
+      LIOPT = LIWMIN
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LOPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL DPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK,
+     $             INFO )
+      LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) )
+      LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) )
+*
+      IF( WANTZ .AND. INFO.EQ.0 ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LOPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of DSYGVD
+*
+      END
diff --git a/SRC/dsygvx.f b/SRC/dsygvx.f
new file mode 100644
index 00000000..e37c1dca
--- /dev/null
+++ b/SRC/dsygvx.f
@@ -0,0 +1,333 @@
+      SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
+     $                   VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
+     $                   LWORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A
+*  and B are assumed to be symmetric and B is also positive definite.
+*  Eigenvalues and eigenvectors can be selected by specifying either a
+*  range of values or a range of indices for the desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A and B are stored;
+*          = 'L':  Lower triangle of A and B are stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix pencil (A,B).  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, 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).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the symmetric matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= 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 the array WORK.  LWORK >= max(1,8*N).
+*          For optimal efficiency, LWORK >= (NB+3)*N,
+*          where NB is the blocksize for DSYTRD returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  DPOTRF or DSYEVX returned an error code:
+*             <= N:  if INFO = i, DSYEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKMIN, LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      UPPER = LSAME( UPLO, 'U' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF (INFO.EQ.0) THEN
+         IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKMIN = MAX( 1, 8*N )
+         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYGVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL DPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
+     $             M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+     $                  LDB, Z, LDZ )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+     $                  LDB, Z, LDZ )
+         END IF
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DSYGVX
+*
+      END
diff --git a/SRC/dsyrfs.f b/SRC/dsyrfs.f
new file mode 100644
index 00000000..ee546c63
--- /dev/null
+++ b/SRC/dsyrfs.f
@@ -0,0 +1,339 @@
+      SUBROUTINE DSYRFS( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite, and
+*  provides error bounds and backward error estimates for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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(1,N).
+*
+*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
+*          The factored form of the matrix A.  AF contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by DSYTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= 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) 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 DSYTRS.
+*          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            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DSYMV, DSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                   INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DSYRFS
+*
+      END
diff --git a/SRC/dsysv.f b/SRC/dsysv.f
new file mode 100644
index 00000000..add53850
--- /dev/null
+++ b/SRC/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/dsysvx.f b/SRC/dsysvx.f
new file mode 100644
index 00000000..1a79d1d1
--- /dev/null
+++ b/SRC/dsysvx.f
@@ -0,0 +1,300 @@
+      SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+     $                   LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYSVX uses the diagonal pivoting factorization to compute the
+*  solution to a real system of linear equations A * X = B,
+*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.
+*     The form of the factorization is
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices, and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AF and IPIV contain the factored form of
+*                  A.  AF and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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(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 block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T.
+*
+*  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 details of the interchanges and the block structure
+*          of D, as determined by DSYTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by DSYTRF.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix 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.
+*
+*  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.  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 (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= max(1,3*N), and for best
+*          performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
+*          NB is the optimal blocksize for DSYTRF.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  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:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOFACT
+      INTEGER            LWKOPT, NB
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANSY
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DSYCON, DSYRFS, DSYTRF, DSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKOPT = MAX( 1, 3*N )
+         IF( NOFACT ) THEN
+            NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = MAX( LWKOPT, N*NB )
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYSVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = DLANSY( 'I', UPLO, N, A, LDA, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK,
+     $             INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DSYSVX
+*
+      END
diff --git a/SRC/dsytd2.f b/SRC/dsytd2.f
new file mode 100644
index 00000000..c696818e
--- /dev/null
+++ b/SRC/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/dsytf2.f b/SRC/dsytf2.f
new file mode 100644
index 00000000..d5234625
--- /dev/null
+++ b/SRC/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/dsytrd.f b/SRC/dsytrd.f
new file mode 100644
index 00000000..569ee35b
--- /dev/null
+++ b/SRC/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/dsytrf.f b/SRC/dsytrf.f
new file mode 100644
index 00000000..43a31248
--- /dev/null
+++ b/SRC/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/dsytri.f b/SRC/dsytri.f
new file mode 100644
index 00000000..361de9a3
--- /dev/null
+++ b/SRC/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/dsytrs.f b/SRC/dsytrs.f
new file mode 100644
index 00000000..163ed5b9
--- /dev/null
+++ b/SRC/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/dtbcon.f b/SRC/dtbcon.f
new file mode 100644
index 00000000..1acdad6c
--- /dev/null
+++ b/SRC/dtbcon.f
@@ -0,0 +1,202 @@
+      SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, 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, KD, LDAB, N
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTBCON estimates the reciprocal of the condition number of a
+*  triangular band matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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, DLANTB
+      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLATBS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = DLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the norm of the inverse of A.
+*
+         AINVNM = ZERO
+         NORMIN = 'N'
+         IF( ONENRM ) THEN
+            KASE1 = 1
+         ELSE
+            KASE1 = 2
+         END IF
+         KASE = 0
+   10    CONTINUE
+         CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL DLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
+     $                      AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL DLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB,
+     $                      LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = IDAMAX( N, WORK, 1 )
+               XNORM = ABS( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL DRSCL( N, SCALE, WORK, 1 )
+            END IF
+            GO TO 10
+         END IF
+*
+*        Compute the estimate of the reciprocal condition number.
+*
+         IF( AINVNM.NE.ZERO )
+     $      RCOND = ( ONE / ANORM ) / AINVNM
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DTBCON
+*
+      END
diff --git a/SRC/dtbrfs.f b/SRC/dtbrfs.f
new file mode 100644
index 00000000..a0023f7c
--- /dev/null
+++ b/SRC/dtbrfs.f
@@ -0,0 +1,385 @@
+      SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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          DIAG, TRANS, UPLO
+      INTEGER            INFO, KD, LDAB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTBRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular band
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by DTBTRS or some other
+*  means before entering this routine.  DTBRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*          The 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANST
+      INTEGER            I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DTBMV, DTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = KD + 2
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A or A', depending on TRANS.
+*
+         CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ),
+     $               1 )
+         CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 30 I = MAX( 1, K-KD ), K
+                        WORK( I ) = WORK( I ) +
+     $                              ABS( AB( KD+1+I-K, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 50 I = MAX( 1, K-KD ), K - 1
+                        WORK( I ) = WORK( I ) +
+     $                              ABS( AB( KD+1+I-K, K ) )*XK
+   50                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 70 I = K, MIN( N, K+KD )
+                        WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 90 I = K + 1, MIN( N, K+KD )
+                        WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+   90                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A')*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = MAX( 1, K-KD ), K
+                        S = S + ABS( AB( KD+1+I-K, K ) )*
+     $                      ABS( X( I, J ) )
+  110                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 130 I = MAX( 1, K-KD ), K - 1
+                        S = S + ABS( AB( KD+1+I-K, K ) )*
+     $                      ABS( X( I, J ) )
+  130                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, MIN( N, K+KD )
+                        S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+  150                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 170 I = K + 1, MIN( N, K+KD )
+                        S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+  170                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)').
+*
+               CALL DTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB,
+     $                     WORK( N+1 ), 1 )
+               DO 220 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  230          CONTINUE
+               CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB,
+     $                     WORK( N+1 ), 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of DTBRFS
+*
+      END
diff --git a/SRC/dtbtrs.f b/SRC/dtbtrs.f
new file mode 100644
index 00000000..1dc90b9b
--- /dev/null
+++ b/SRC/dtbtrs.f
@@ -0,0 +1,162 @@
+      SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTBTRS solves a triangular system of the form
+*
+*     A * X = B  or  A**T * X = B,
+*
+*  where A is a triangular band matrix of order N, and B is an
+*  N-by NRHS matrix.  A check is made to verify that A is nonsingular.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  A is upper triangular;
+*          = 'L':  A is lower triangular.
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form the system of equations:
+*          = 'N':  A * X = B  (No transpose)
+*          = 'T':  A**T * X = B  (Transpose)
+*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOUNIT = LSAME( DIAG, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            DO 10 INFO = 1, N
+               IF( AB( KD+1, INFO ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            DO 20 INFO = 1, N
+               IF( AB( 1, INFO ).EQ.ZERO )
+     $            RETURN
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve A * X = B  or  A' * X = B.
+*
+      DO 30 J = 1, NRHS
+         CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of DTBTRS
+*
+      END
diff --git a/SRC/dtgevc.f b/SRC/dtgevc.f
new file mode 100644
index 00000000..091c3f65
--- /dev/null
+++ b/SRC/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/dtgex2.f b/SRC/dtgex2.f
new file mode 100644
index 00000000..8351b7fd
--- /dev/null
+++ b/SRC/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/dtgexc.f b/SRC/dtgexc.f
new file mode 100644
index 00000000..bafefea2
--- /dev/null
+++ b/SRC/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/dtgsen.f b/SRC/dtgsen.f
new file mode 100644
index 00000000..90c65ef8
--- /dev/null
+++ b/SRC/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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     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)) 
+*          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/dtgsja.f b/SRC/dtgsja.f
new file mode 100644
index 00000000..a1c12d66
--- /dev/null
+++ b/SRC/dtgsja.f
@@ -0,0 +1,515 @@
+      SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
+     $                   LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV,
+     $                   Q, LDQ, WORK, NCYCLE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
+     $                   NCYCLE, P
+      DOUBLE PRECISION   TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), Q( LDQ, * ), U( LDU, * ),
+     $                   V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGSJA computes the generalized singular value decomposition (GSVD)
+*  of two real upper triangular (or trapezoidal) matrices A and B.
+*
+*  On entry, it is assumed that matrices A and B have the following
+*  forms, which may be obtained by the preprocessing subroutine DGGSVP
+*  from a general M-by-N matrix A and P-by-N matrix B:
+*
+*               N-K-L  K    L
+*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;
+*            L ( 0     0   A23 )
+*        M-K-L ( 0     0    0  )
+*
+*             N-K-L  K    L
+*     A =  K ( 0    A12  A13 ) if M-K-L < 0;
+*        M-K ( 0     0   A23 )
+*
+*             N-K-L  K    L
+*     B =  L ( 0     0   B13 )
+*        P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.
+*
+*  On exit,
+*
+*              U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),
+*
+*  where U, V and Q are orthogonal matrices, Z' denotes the transpose
+*  of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
+*  ``diagonal'' matrices, which are of the following structures:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                    K  L
+*         D2 = L   ( 0  S )
+*              P-L ( 0  0 )
+*
+*                 N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 ) K
+*              L (  0    0   R22 ) L
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                 K M-K K+L-M
+*      D1 =   K ( I  0    0   )
+*           M-K ( 0  C    0   )
+*
+*                   K M-K K+L-M
+*      D2 =   M-K ( 0  S    0   )
+*           K+L-M ( 0  0    I   )
+*             P-L ( 0  0    0   )
+*
+*                 N-K-L  K   M-K  K+L-M
+* ( 0 R ) =    K ( 0    R11  R12  R13  )
+*            M-K ( 0     0   R22  R23  )
+*          K+L-M ( 0     0    0   R33  )
+*
+*  where
+*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*  S = diag( BETA(K+1),  ... , BETA(M) ),
+*  C**2 + S**2 = I.
+*
+*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
+*      (  0  R22 R23 )
+*  in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The computation of the orthogonal transformation matrices U, V or Q
+*  is optional.  These matrices may either be formed explicitly, or they
+*  may be postmultiplied into input matrices U1, V1, or Q1.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  U must contain an orthogonal matrix U1 on entry, and
+*                  the product U1*U is returned;
+*          = 'I':  U is initialized to the unit matrix, and the
+*                  orthogonal matrix U is returned;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  V must contain an orthogonal matrix V1 on entry, and
+*                  the product V1*V is returned;
+*          = 'I':  V is initialized to the unit matrix, and the
+*                  orthogonal matrix V is returned;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Q must contain an orthogonal matrix Q1 on entry, and
+*                  the product Q1*Q is returned;
+*          = 'I':  Q is initialized to the unit matrix, and the
+*                  orthogonal matrix Q is returned;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  K       (input) INTEGER
+*  L       (input) INTEGER
+*          K and L specify the subblocks in the input matrices A and B:
+*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
+*          of A and B, whose GSVD is going to be computed by DTGSJA.
+*          See Further details.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
+*          matrix R or part of R.  See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
+*          a part of R.  See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) DOUBLE PRECISION
+*  TOLB    (input) DOUBLE PRECISION
+*          TOLA and TOLB are the convergence criteria for the Jacobi-
+*          Kogbetliantz iteration procedure. Generally, they are the
+*          same as used in the preprocessing step, say
+*              TOLA = max(M,N)*norm(A)*MAZHEPS,
+*              TOLB = max(P,N)*norm(B)*MAZHEPS.
+*
+*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = diag(C),
+*            BETA(K+1:K+L)  = diag(S),
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
+*          Furthermore, if K+L < N,
+*            ALPHA(K+L+1:N) = 0 and
+*            BETA(K+L+1:N)  = 0.
+*
+*  U       (input/output) DOUBLE PRECISION array, dimension (LDU,M)
+*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
+*          the orthogonal matrix returned by DGGSVP).
+*          On exit,
+*          if JOBU = 'I', U contains the orthogonal matrix U;
+*          if JOBU = 'U', U contains the product U1*U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,P)
+*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
+*          the orthogonal matrix returned by DGGSVP).
+*          On exit,
+*          if JOBV = 'I', V contains the orthogonal matrix V;
+*          if JOBV = 'V', V contains the product V1*V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
+*          the orthogonal matrix returned by DGGSVP).
+*          On exit,
+*          if JOBQ = 'I', Q contains the orthogonal matrix Q;
+*          if JOBQ = 'Q', Q contains the product Q1*Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  NCYCLE  (output) INTEGER
+*          The number of cycles required for convergence.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the procedure does not converge after MAXIT cycles.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXIT   INTEGER
+*          MAXIT specifies the total loops that the iterative procedure
+*          may take. If after MAXIT cycles, the routine fails to
+*          converge, we return INFO = 1.
+*
+*  Further Details
+*  ===============
+*
+*  DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
+*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
+*  matrix B13 to the form:
+*
+*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
+*
+*  where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
+*  of Z.  C1 and S1 are diagonal matrices satisfying
+*
+*                C1**2 + S1**2 = I,
+*
+*  and R1 is an L-by-L nonsingular upper triangular matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 40 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+*
+      LOGICAL            INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
+      INTEGER            I, J, KCYCLE
+      DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
+     $                   GAMMA, RWK, SNQ, SNU, SNV, SSMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT,
+     $                   DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      INITU = LSAME( JOBU, 'I' )
+      WANTU = INITU .OR. LSAME( JOBU, 'U' )
+*
+      INITV = LSAME( JOBV, 'I' )
+      WANTV = INITV .OR. LSAME( JOBV, 'V' )
+*
+      INITQ = LSAME( JOBQ, 'I' )
+      WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -18
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -20
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -22
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGSJA', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize U, V and Q, if necessary
+*
+      IF( INITU )
+     $   CALL DLASET( 'Full', M, M, ZERO, ONE, U, LDU )
+      IF( INITV )
+     $   CALL DLASET( 'Full', P, P, ZERO, ONE, V, LDV )
+      IF( INITQ )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+*     Loop until convergence
+*
+      UPPER = .FALSE.
+      DO 40 KCYCLE = 1, MAXIT
+*
+         UPPER = .NOT.UPPER
+*
+         DO 20 I = 1, L - 1
+            DO 10 J = I + 1, L
+*
+               A1 = ZERO
+               A2 = ZERO
+               A3 = ZERO
+               IF( K+I.LE.M )
+     $            A1 = A( K+I, N-L+I )
+               IF( K+J.LE.M )
+     $            A3 = A( K+J, N-L+J )
+*
+               B1 = B( I, N-L+I )
+               B3 = B( J, N-L+J )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A2 = A( K+I, N-L+J )
+                  B2 = B( I, N-L+J )
+               ELSE
+                  IF( K+J.LE.M )
+     $               A2 = A( K+J, N-L+I )
+                  B2 = B( J, N-L+I )
+               END IF
+*
+               CALL DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
+     $                      CSV, SNV, CSQ, SNQ )
+*
+*              Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
+*
+               IF( K+J.LE.M )
+     $            CALL DROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
+     $                       LDA, CSU, SNU )
+*
+*              Update I-th and J-th rows of matrix B: V'*B
+*
+               CALL DROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
+     $                    CSV, SNV )
+*
+*              Update (N-L+I)-th and (N-L+J)-th columns of matrices
+*              A and B: A*Q and B*Q
+*
+               CALL DROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
+     $                    A( 1, N-L+I ), 1, CSQ, SNQ )
+*
+               CALL DROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
+     $                    SNQ )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A( K+I, N-L+J ) = ZERO
+                  B( I, N-L+J ) = ZERO
+               ELSE
+                  IF( K+J.LE.M )
+     $               A( K+J, N-L+I ) = ZERO
+                  B( J, N-L+I ) = ZERO
+               END IF
+*
+*              Update orthogonal matrices U, V, Q, if desired.
+*
+               IF( WANTU .AND. K+J.LE.M )
+     $            CALL DROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
+     $                       SNU )
+*
+               IF( WANTV )
+     $            CALL DROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
+*
+               IF( WANTQ )
+     $            CALL DROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
+     $                       SNQ )
+*
+   10       CONTINUE
+   20    CONTINUE
+*
+         IF( .NOT.UPPER ) THEN
+*
+*           The matrices A13 and B13 were lower triangular at the start
+*           of the cycle, and are now upper triangular.
+*
+*           Convergence test: test the parallelism of the corresponding
+*           rows of A and B.
+*
+            ERROR = ZERO
+            DO 30 I = 1, MIN( L, M-K )
+               CALL DCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
+               CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
+               CALL DLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
+               ERROR = MAX( ERROR, SSMIN )
+   30       CONTINUE
+*
+            IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
+     $         GO TO 50
+         END IF
+*
+*        End of cycle loop
+*
+   40 CONTINUE
+*
+*     The algorithm has not converged after MAXIT cycles.
+*
+      INFO = 1
+      GO TO 100
+*
+   50 CONTINUE
+*
+*     If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
+*     Compute the generalized singular value pairs (ALPHA, BETA), and
+*     set the triangular matrix R to array A.
+*
+      DO 60 I = 1, K
+         ALPHA( I ) = ONE
+         BETA( I ) = ZERO
+   60 CONTINUE
+*
+      DO 70 I = 1, MIN( L, M-K )
+*
+         A1 = A( K+I, N-L+I )
+         B1 = B( I, N-L+I )
+*
+         IF( A1.NE.ZERO ) THEN
+            GAMMA = B1 / A1
+*
+*           change sign if necessary
+*
+            IF( GAMMA.LT.ZERO ) THEN
+               CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
+               IF( WANTV )
+     $            CALL DSCAL( P, -ONE, V( 1, I ), 1 )
+            END IF
+*
+            CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
+     $                   RWK )
+*
+            IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
+               CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
+     $                     LDA )
+            ELSE
+               CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
+     $                     LDB )
+               CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                     LDA )
+            END IF
+*
+         ELSE
+*
+            ALPHA( K+I ) = ZERO
+            BETA( K+I ) = ONE
+            CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                  LDA )
+*
+         END IF
+*
+   70 CONTINUE
+*
+*     Post-assignment
+*
+      DO 80 I = M + 1, K + L
+         ALPHA( I ) = ZERO
+         BETA( I ) = ONE
+   80 CONTINUE
+*
+      IF( K+L.LT.N ) THEN
+         DO 90 I = K + L + 1, N
+            ALPHA( I ) = ZERO
+            BETA( I ) = ZERO
+   90    CONTINUE
+      END IF
+*
+  100 CONTINUE
+      NCYCLE = KCYCLE
+      RETURN
+*
+*     End of DTGSJA
+*
+      END
diff --git a/SRC/dtgsna.f b/SRC/dtgsna.f
new file mode 100644
index 00000000..b0803d89
--- /dev/null
+++ b/SRC/dtgsna.f
@@ -0,0 +1,580 @@
+      SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, JOB
+      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
+     $                   VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or eigenvectors of a matrix pair (A, B) in
+*  generalized real Schur canonical form (or of any matrix pair
+*  (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
+*  Z' denotes the transpose of Z.
+*
+*  (A, B) must be in generalized real Schur form (as returned by DGGES),
+*  i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
+*  blocks. B is upper triangular.
+*
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (DIF):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (DIF);
+*          = 'B': for both eigenvalues and eigenvectors (S and DIF).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the eigenpair corresponding to a real eigenvalue w(j),
+*          SELECT(j) must be set to .TRUE.. To select condition numbers
+*          corresponding to a complex conjugate pair of eigenvalues w(j)
+*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+*          set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the square matrix pair (A, B). N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The upper quasi-triangular matrix A in the pair (A,B).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
+*          The upper triangular matrix B in the pair (A,B).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)
+*          If JOB = 'E' or 'B', VL must contain left eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT. The eigenvectors must be stored in consecutive
+*          columns of VL, as returned by DTGEVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL. LDVL >= 1.
+*          If JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)
+*          If JOB = 'E' or 'B', VR must contain right eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT. The eigenvectors must be stored in consecutive
+*          columns ov VR, as returned by DTGEVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR. LDVR >= 1.
+*          If JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array. For a complex conjugate pair of eigenvalues two
+*          consecutive elements of S are set to the same value. Thus
+*          S(j), DIF(j), and the j-th columns of VL and VR all
+*          correspond to the same eigenpair (but not in general the
+*          j-th eigenpair, unless all eigenpairs are selected).
+*          If JOB = 'V', S is not referenced.
+*
+*  DIF     (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array. For a complex eigenvector two
+*          consecutive elements of DIF are set to the same value. If
+*          the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
+*          is set to 0; this can only occur when the true value would be
+*          very small anyway.
+*          If JOB = 'E', DIF is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S and DIF. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and DIF used to store
+*          the specified condition numbers; for each selected real
+*          eigenvalue one element is used, and for each selected complex
+*          conjugate pair of eigenvalues, two elements are used.
+*          If HOWMNY = 'A', M is set to N.
+*
+*  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 JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N + 6)
+*          If JOB = 'E', IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          =0: Successful exit
+*          <0: If INFO = -i, the i-th argument had an illegal value
+*
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of a generalized eigenvalue
+*  w = (a, b) is defined as
+*
+*       S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
+*
+*  where u and v are the left and right eigenvectors of (A, B)
+*  corresponding to w; |z| denotes the absolute value of the complex
+*  number, and norm(u) denotes the 2-norm of the vector u.
+*  The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
+*  of the matrix pair (A, B). If both a and b equal zero, then (A B) is
+*  singular and S(I) = -1 is returned.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*       chord(w, lambda) <= EPS * norm(A, B) / S(I)
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number DIF(i) of right eigenvector u
+*  and left eigenvector v corresponding to the generalized eigenvalue w
+*  is defined as follows:
+*
+*  a) If the i-th eigenvalue w = (a,b) is real
+*
+*     Suppose U and V are orthogonal transformations such that
+*
+*                U'*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1
+*                                        ( 0  S22 ),( 0 T22 )  n-1
+*                                          1  n-1     1 n-1
+*
+*     Then the reciprocal condition number DIF(i) is
+*
+*                Difl((a, b), (S22, T22)) = sigma-min( Zl ),
+*
+*     where sigma-min(Zl) denotes the smallest singular value of the
+*     2(n-1)-by-2(n-1) matrix
+*
+*         Zl = [ kron(a, In-1)  -kron(1, S22) ]
+*              [ kron(b, In-1)  -kron(1, T22) ] .
+*
+*     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
+*     Kronecker product between the matrices X and Y.
+*
+*     Note that if the default method for computing DIF(i) is wanted
+*     (see DLATDF), then the parameter DIFDRI (see below) should be
+*     changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).
+*     See DTGSYL for more details.
+*
+*  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
+*
+*     Suppose U and V are orthogonal transformations such that
+*
+*                U'*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2
+*                                       ( 0    S22 ),( 0    T22) n-2
+*                                         2    n-2     2    n-2
+*
+*     and (S11, T11) corresponds to the complex conjugate eigenvalue
+*     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
+*     that
+*
+*         U1'*S11*V1 = ( s11 s12 )   and U1'*T11*V1 = ( t11 t12 )
+*                      (  0  s22 )                    (  0  t22 )
+*
+*     where the generalized eigenvalues w = s11/t11 and
+*     conjg(w) = s22/t22.
+*
+*     Then the reciprocal condition number DIF(i) is bounded by
+*
+*         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
+*
+*     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
+*     Z1 is the complex 2-by-2 matrix
+*
+*              Z1 =  [ s11  -s22 ]
+*                    [ t11  -t22 ],
+*
+*     This is done by computing (using real arithmetic) the
+*     roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
+*     where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
+*     the determinant of X.
+*
+*     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
+*     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
+*
+*              Z2 = [ kron(S11', In-2)  -kron(I2, S22) ]
+*                   [ kron(T11', In-2)  -kron(I2, T22) ]
+*
+*     Note that if the default method for computing DIF is wanted (see
+*     DLATDF), then the parameter DIFDRI (see below) should be changed
+*     from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL
+*     for more details.
+*
+*  For each eigenvalue/vector specified by SELECT, DIF stores a
+*  Frobenius norm-based estimate of Difl.
+*
+*  An approximate error bound for the i-th computed eigenvector VL(i) or
+*  VR(i) is given by
+*
+*             EPS * norm(A, B) / DIF(i).
+*
+*  See ref. [2-3] for more details and further references.
+*
+*  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            DIFDRI
+      PARAMETER          ( DIFDRI = 3 )
+      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+     $                   FOUR = 4.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
+      INTEGER            I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
+      DOUBLE PRECISION   ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
+     $                   EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
+     $                   TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
+     $                   UHBVI
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUMMY( 1 ), DUMMY1( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT, DLAMCH, DLAPY2, DNRM2
+      EXTERNAL           LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DLACPY, DLAG2, DTGEXC, DTGSYL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
+         INFO = -10
+      ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
+         INFO = -12
+      ELSE
+*
+*        Set M to the number of eigenpairs for which condition numbers
+*        are required, and test MM.
+*
+         IF( SOMCON ) THEN
+            M = 0
+            PAIR = .FALSE.
+            DO 10 K = 1, N
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+               ELSE
+                  IF( K.LT.N ) THEN
+                     IF( A( K+1, K ).EQ.ZERO ) THEN
+                        IF( SELECT( K ) )
+     $                     M = M + 1
+                     ELSE
+                        PAIR = .TRUE.
+                        IF( SELECT( K ) .OR. SELECT( K+1 ) )
+     $                     M = M + 2
+                     END IF
+                  ELSE
+                     IF( SELECT( N ) )
+     $                  M = M + 1
+                  END IF
+               END IF
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( N.EQ.0 ) THEN
+            LWMIN = 1
+         ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
+            LWMIN = 2*N*( N + 2 ) + 16
+         ELSE
+            LWMIN = N
+         END IF
+         WORK( 1 ) = LWMIN
+*
+         IF( MM.LT.M ) THEN
+            INFO = -15
+         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGSNA', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      KS = 0
+      PAIR = .FALSE.
+*
+      DO 20 K = 1, N
+*
+*        Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+            GO TO 20
+         ELSE
+            IF( K.LT.N )
+     $         PAIR = A( K+1, K ).NE.ZERO
+         END IF
+*
+*        Determine whether condition numbers are required for the k-th
+*        eigenpair.
+*
+         IF( SOMCON ) THEN
+            IF( PAIR ) THEN
+               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+     $            GO TO 20
+            ELSE
+               IF( .NOT.SELECT( K ) )
+     $            GO TO 20
+            END IF
+         END IF
+*
+         KS = KS + 1
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            IF( PAIR ) THEN
+*
+*              Complex eigenvalue pair.
+*
+               RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
+     $                DNRM2( N, VR( 1, KS+1 ), 1 ) )
+               LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
+     $                DNRM2( N, VL( 1, KS+1 ), 1 ) )
+               CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
+     $                     ZERO, WORK, 1 )
+               TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               UHAV = TMPRR + TMPII
+               UHAVI = TMPIR - TMPRI
+               CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
+     $                     ZERO, WORK, 1 )
+               TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               UHBV = TMPRR + TMPII
+               UHBVI = TMPIR - TMPRI
+               UHAV = DLAPY2( UHAV, UHAVI )
+               UHBV = DLAPY2( UHBV, UHBVI )
+               COND = DLAPY2( UHAV, UHBV )
+               S( KS ) = COND / ( RNRM*LNRM )
+               S( KS+1 ) = S( KS )
+*
+            ELSE
+*
+*              Real eigenvalue.
+*
+               RNRM = DNRM2( N, VR( 1, KS ), 1 )
+               LNRM = DNRM2( N, VL( 1, KS ), 1 )
+               CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               UHAV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               UHBV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               COND = DLAPY2( UHAV, UHBV )
+               IF( COND.EQ.ZERO ) THEN
+                  S( KS ) = -ONE
+               ELSE
+                  S( KS ) = COND / ( RNRM*LNRM )
+               END IF
+            END IF
+         END IF
+*
+         IF( WANTDF ) THEN
+            IF( N.EQ.1 ) THEN
+               DIF( KS ) = DLAPY2( A( 1, 1 ), B( 1, 1 ) )
+               GO TO 20
+            END IF
+*
+*           Estimate the reciprocal condition number of the k-th
+*           eigenvectors.
+            IF( PAIR ) THEN
+*
+*              Copy the  2-by 2 pencil beginning at (A(k,k), B(k, k)).
+*              Compute the eigenvalue(s) at position K.
+*
+               WORK( 1 ) = A( K, K )
+               WORK( 2 ) = A( K+1, K )
+               WORK( 3 ) = A( K, K+1 )
+               WORK( 4 ) = A( K+1, K+1 )
+               WORK( 5 ) = B( K, K )
+               WORK( 6 ) = B( K+1, K )
+               WORK( 7 ) = B( K, K+1 )
+               WORK( 8 ) = B( K+1, K+1 )
+               CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
+     $                     DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
+               ALPRQT = ONE
+               C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
+               C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
+               ROOT1 = C1 + SQRT( C1*C1-4.0D0*C2 )
+               ROOT2 = C2 / ROOT1
+               ROOT1 = ROOT1 / TWO
+               COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
+            END IF
+*
+*           Copy the matrix (A, B) to the array WORK and swap the
+*           diagonal block beginning at A(k,k) to the (1,1) position.
+*
+            CALL DLACPY( 'Full', N, N, A, LDA, WORK, N )
+            CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+            IFST = K
+            ILST = 1
+*
+            CALL DTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
+     $                   DUMMY, 1, DUMMY1, 1, IFST, ILST,
+     $                   WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
+*
+            IF( IERR.GT.0 ) THEN
+*
+*              Ill-conditioned problem - swap rejected.
+*
+               DIF( KS ) = ZERO
+            ELSE
+*
+*              Reordering successful, solve generalized Sylvester
+*              equation for R and L,
+*                         A22 * R - L * A11 = A12
+*                         B22 * R - L * B11 = B12,
+*              and compute estimate of Difl((A11,B11), (A22, B22)).
+*
+               N1 = 1
+               IF( WORK( 2 ).NE.ZERO )
+     $            N1 = 2
+               N2 = N - N1
+               IF( N2.EQ.0 ) THEN
+                  DIF( KS ) = COND
+               ELSE
+                  I = N*N + 1
+                  IZ = 2*N*N + 1
+                  CALL DTGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
+     $                         N, WORK, N, WORK( N1+1 ), N,
+     $                         WORK( N*N1+N1+I ), N, WORK( I ), N,
+     $                         WORK( N1+I ), N, SCALE, DIF( KS ),
+     $                         WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
+*
+                  IF( PAIR )
+     $               DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
+     $                           COND )
+               END IF
+            END IF
+            IF( PAIR )
+     $         DIF( KS+1 ) = DIF( KS )
+         END IF
+         IF( PAIR )
+     $      KS = KS + 1
+*
+   20 CONTINUE
+      WORK( 1 ) = LWMIN
+      RETURN
+*
+*     End of DTGSNA
+*
+      END
diff --git a/SRC/dtgsy2.f b/SRC/dtgsy2.f
new file mode 100644
index 00000000..3701e84a
--- /dev/null
+++ b/SRC/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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. 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 DTGSYL
+*  of an upper bound on the separation between to matrix pairs. Then
+*  the input (A, D), (B, E) are sub-pencils of the matrix pair in
+*  DTGSYL. See DTGSYL for details.
+*
+*  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 DTGSYL.
+*
+*  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 ), LDE, F( IS, JE+1 ), LDF )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+*                 Build an 8-by-8 system Z * x = RHS
+*
+                  CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = A( ISP1, IS )
+                  Z( 5, 1 ) = D( IS, IS )
+*
+                  Z( 1, 2 ) = A( IS, ISP1 )
+                  Z( 2, 2 ) = A( ISP1, ISP1 )
+                  Z( 5, 2 ) = D( IS, ISP1 )
+                  Z( 6, 2 ) = D( ISP1, ISP1 )
+*
+                  Z( 3, 3 ) = A( IS, IS )
+                  Z( 4, 3 ) = A( ISP1, IS )
+                  Z( 7, 3 ) = D( IS, IS )
+*
+                  Z( 3, 4 ) = A( IS, ISP1 )
+                  Z( 4, 4 ) = A( ISP1, ISP1 )
+                  Z( 7, 4 ) = D( IS, ISP1 )
+                  Z( 8, 4 ) = D( ISP1, ISP1 )
+*
+                  Z( 1, 5 ) = -B( JS, JS )
+                  Z( 3, 5 ) = -B( JS, JSP1 )
+                  Z( 5, 5 ) = -E( JS, JS )
+                  Z( 7, 5 ) = -E( JS, JSP1 )
+*
+                  Z( 2, 6 ) = -B( JS, JS )
+                  Z( 4, 6 ) = -B( JS, JSP1 )
+                  Z( 6, 6 ) = -E( JS, JS )
+                  Z( 8, 6 ) = -E( JS, JSP1 )
+*
+                  Z( 1, 7 ) = -B( JSP1, JS )
+                  Z( 3, 7 ) = -B( JSP1, JSP1 )
+                  Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+                  Z( 2, 8 ) = -B( JSP1, JS )
+                  Z( 4, 8 ) = -B( JSP1, JSP1 )
+                  Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+*                 Set up right hand side(s)
+*
+                  K = 1
+                  II = MB*NB + 1
+                  DO 80 JJ = 0, NB - 1
+                     CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+                     CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+                     K = K + MB
+                     II = II + MB
+   80             CONTINUE
+*
+*                 Solve Z * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 90 K = 1, N
+                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+   90                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+     $                            RDSCAL, IPIV, JPIV )
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  K = 1
+                  II = MB*NB + 1
+                  DO 100 JJ = 0, NB - 1
+                     CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+                     CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+                     K = K + MB
+                     II = II + MB
+  100             CONTINUE
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( I.GT.1 ) THEN
+                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
+     $                           C( 1, JS ), LDC )
+                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
+     $                           F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     K = MB*NB + 1
+                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+     $                           MB, B( JS, JE+1 ), LDB, ONE,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+     $                           MB, E( JS, JE+1 ), LDE, ONE,
+     $                           F( IS, JE+1 ), LDF )
+                  END IF
+*
+               END IF
+*
+  110       CONTINUE
+  120    CONTINUE
+      ELSE
+*
+*        Solve (I, J) - subsystem
+*             A(I, I)' * 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/dtgsyl.f b/SRC/dtgsyl.f
new file mode 100644
index 00000000..01866717
--- /dev/null
+++ b/SRC/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/dtpcon.f b/SRC/dtpcon.f
new file mode 100644
index 00000000..84b02a85
--- /dev/null
+++ b/SRC/dtpcon.f
@@ -0,0 +1,191 @@
+      SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, 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, N
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTPCON estimates the reciprocal of the condition number of a packed
+*  triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  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, DLANTP
+      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLATPS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the norm of the inverse of A.
+*
+         AINVNM = ZERO
+         NORMIN = 'N'
+         IF( ONENRM ) THEN
+            KASE1 = 1
+         ELSE
+            KASE1 = 2
+         END IF
+         KASE = 0
+   10    CONTINUE
+         CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL DLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
+     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL DLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP,
+     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = IDAMAX( N, WORK, 1 )
+               XNORM = ABS( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL DRSCL( N, SCALE, WORK, 1 )
+            END IF
+            GO TO 10
+         END IF
+*
+*        Compute the estimate of the reciprocal condition number.
+*
+         IF( AINVNM.NE.ZERO )
+     $      RCOND = ( ONE / ANORM ) / AINVNM
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DTPCON
+*
+      END
diff --git a/SRC/dtprfs.f b/SRC/dtprfs.f
new file mode 100644
index 00000000..e10d80c3
--- /dev/null
+++ b/SRC/dtprfs.f
@@ -0,0 +1,379 @@
+      SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, 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          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTPRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular packed
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by DTPTRS or some other
+*  means before entering this routine.  DTPRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  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) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*          The 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANST
+      INTEGER            I, J, K, KASE, KC, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DTPMV, DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A or A', depending on TRANS.
+*
+         CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+         CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 30 I = 1, K
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+   30                CONTINUE
+                     KC = KC + K
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+   50                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+                     KC = KC + K
+   60             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 70 I = K, N
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+   70                CONTINUE
+                     KC = KC + N - K + 1
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+   90                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+                     KC = KC + N - K + 1
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A')*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+  110                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + K
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+  130                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + K
+  140             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+  150                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + N - K + 1
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+  170                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + N - K + 1
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)').
+*
+               CALL DTPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
+               DO 220 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  230          CONTINUE
+               CALL DTPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of DTPRFS
+*
+      END
diff --git a/SRC/dtptri.f b/SRC/dtptri.f
new file mode 100644
index 00000000..7aca893a
--- /dev/null
+++ b/SRC/dtptri.f
@@ -0,0 +1,175 @@
+      SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTPTRI computes the inverse of a real upper or lower triangular
+*  matrix A stored in packed format.
+*
+*  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.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangular matrix A, stored
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same packed storage format.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  A triangular matrix A can be transferred to packed storage using one
+*  of the following program segments:
+*
+*  UPLO = 'U':                      UPLO = 'L':
+*
+*        JC = 1                           JC = 1
+*        DO 2 J = 1, N                    DO 2 J = 1, N
+*           DO 1 I = 1, J                    DO 1 I = J, N
+*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
+*      1    CONTINUE                    1    CONTINUE
+*           JC = JC + J                      JC = JC + N - J + 1
+*      2 CONTINUE                       2 CONTINUE
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC, JCLAST, JJ
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DTPMV, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Check for singularity if non-unit.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JJ = 0
+            DO 10 INFO = 1, N
+               JJ = JJ + INFO
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            JJ = 1
+            DO 20 INFO = 1, N
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+               JJ = JJ + N - INFO + 1
+   20       CONTINUE
+         END IF
+         INFO = 0
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Compute inverse of upper triangular matrix.
+*
+         JC = 1
+         DO 30 J = 1, N
+            IF( NOUNIT ) THEN
+               AP( JC+J-1 ) = ONE / AP( JC+J-1 )
+               AJJ = -AP( JC+J-1 )
+            ELSE
+               AJJ = -ONE
+            END IF
+*
+*           Compute elements 1:j-1 of j-th column.
+*
+            CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
+     $                  AP( JC ), 1 )
+            CALL DSCAL( J-1, AJJ, AP( JC ), 1 )
+            JC = JC + J
+   30    CONTINUE
+*
+      ELSE
+*
+*        Compute inverse of lower triangular matrix.
+*
+         JC = N*( N+1 ) / 2
+         DO 40 J = N, 1, -1
+            IF( NOUNIT ) THEN
+               AP( JC ) = ONE / AP( JC )
+               AJJ = -AP( JC )
+            ELSE
+               AJJ = -ONE
+            END IF
+            IF( J.LT.N ) THEN
+*
+*              Compute elements j+1:n of j-th column.
+*
+               CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     AP( JCLAST ), AP( JC+1 ), 1 )
+               CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 )
+            END IF
+            JCLAST = JC
+            JC = JC - N + J - 2
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DTPTRI
+*
+      END
diff --git a/SRC/dtptrs.f b/SRC/dtptrs.f
new file mode 100644
index 00000000..307a01d8
--- /dev/null
+++ b/SRC/dtptrs.f
@@ -0,0 +1,153 @@
+      SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTPTRS solves a triangular system of the form
+*
+*     A * X = B  or  A**T * X = B,
+*
+*  where A is a triangular matrix of order N stored in packed format,
+*  and B is an N-by-NRHS matrix.  A check is made to verify that A is
+*  nonsingular.
+*
+*  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.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  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
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTPTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JC = 1
+            DO 10 INFO = 1, N
+               IF( AP( JC+INFO-1 ).EQ.ZERO )
+     $            RETURN
+               JC = JC + INFO
+   10       CONTINUE
+         ELSE
+            JC = 1
+            DO 20 INFO = 1, N
+               IF( AP( JC ).EQ.ZERO )
+     $            RETURN
+               JC = JC + N - INFO + 1
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve A * x = b  or  A' * x = b.
+*
+      DO 30 J = 1, NRHS
+         CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of DTPTRS
+*
+      END
diff --git a/SRC/dtrcon.f b/SRC/dtrcon.f
new file mode 100644
index 00000000..23da5927
--- /dev/null
+++ b/SRC/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/dtrevc.f b/SRC/dtrevc.f
new file mode 100644
index 00000000..a0215f02
--- /dev/null
+++ b/SRC/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/dtrexc.f b/SRC/dtrexc.f
new file mode 100644
index 00000000..db9be753
--- /dev/null
+++ b/SRC/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/dtrrfs.f b/SRC/dtrrfs.f
new file mode 100644
index 00000000..77cf6c81
--- /dev/null
+++ b/SRC/dtrrfs.f
@@ -0,0 +1,375 @@
+      SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, 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          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDA, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by DTRTRS or some other
+*  means before entering this routine.  DTRRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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 matrices B and X.  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) 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) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*          The 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANST
+      INTEGER            I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DLACN2, DTRMV, DTRSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A or A', depending on TRANS.
+*
+         CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
+         CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 30 I = 1, K
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   50                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 70 I = K, N
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   90                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A')*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  110                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  130                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  150                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  170                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)').
+*
+               CALL DTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ),
+     $                     1 )
+               DO 220 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  230          CONTINUE
+               CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ),
+     $                     1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of DTRRFS
+*
+      END
diff --git a/SRC/dtrsen.f b/SRC/dtrsen.f
new file mode 100644
index 00000000..1d3ab03a
--- /dev/null
+++ b/SRC/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/dtrsna.f b/SRC/dtrsna.f
new file mode 100644
index 00000000..72b5d303
--- /dev/null
+++ b/SRC/dtrsna.f
@@ -0,0 +1,495 @@
+      SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, S, SEP, MM, M, WORK, LDWORK, 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          HOWMNY, JOB
+      INTEGER            INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or right eigenvectors of a real upper
+*  quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
+*  orthogonal).
+*
+*  T must be in Schur canonical form (as returned by DHSEQR), that is,
+*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+*  2-by-2 diagonal block has its diagonal elements equal and its
+*  off-diagonal elements of opposite sign.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (SEP):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (SEP);
+*          = 'B': for both eigenvalues and eigenvectors (S and SEP).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the eigenpair corresponding to a real eigenvalue w(j),
+*          SELECT(j) must be set to .TRUE.. To select condition numbers
+*          corresponding to a complex conjugate pair of eigenvalues w(j)
+*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+*          set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  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) DOUBLE PRECISION array, dimension (LDVL,M)
+*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
+*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VL, as returned by
+*          DHSEIN or DTREVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)
+*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
+*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VR, as returned by
+*          DHSEIN or DTREVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array. For a complex conjugate pair of eigenvalues two
+*          consecutive elements of S are set to the same value. Thus
+*          S(j), SEP(j), and the j-th columns of VL and VR all
+*          correspond to the same eigenpair (but not in general the
+*          j-th eigenpair, unless all eigenpairs are selected).
+*          If JOB = 'V', S is not referenced.
+*
+*  SEP     (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array. For a complex eigenvector two
+*          consecutive elements of SEP are set to the same value. If
+*          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
+*          is set to 0; this can only occur when the true value would be
+*          very small anyway.
+*          If JOB = 'E', SEP is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S (if JOB = 'E' or 'B')
+*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and/or SEP actually
+*          used to store the estimated condition numbers.
+*          If HOWMNY = 'A', M is set to N.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)
+*          If JOB = 'E', WORK is not referenced.
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*(N-1))
+*          If JOB = 'E', IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of an eigenvalue lambda is
+*  defined as
+*
+*          S(lambda) = |v'*u| / (norm(u)*norm(v))
+*
+*  where u and v are the right and left eigenvectors of T corresponding
+*  to lambda; v' denotes the conjugate-transpose of v, and norm(u)
+*  denotes the Euclidean norm. These reciprocal condition numbers always
+*  lie between zero (very badly conditioned) and one (very well
+*  conditioned). If n = 1, S(lambda) is defined to be 1.
+*
+*  An approximate error bound for a computed eigenvalue W(i) is given by
+*
+*                      EPS * norm(T) / S(i)
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number of the right eigenvector u
+*  corresponding to lambda is defined as follows. Suppose
+*
+*              T = ( lambda  c  )
+*                  (   0    T22 )
+*
+*  Then the reciprocal condition number is
+*
+*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
+*
+*  where sigma-min denotes the smallest singular value. We approximate
+*  the smallest singular value by the reciprocal of an estimate of the
+*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
+*  defined to be abs(T(1,1)).
+*
+*  An approximate error bound for a computed right eigenvector VR(i)
+*  is given by
+*
+*                      EPS * norm(T) / SEP(i)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            PAIR, SOMCON, WANTBH, WANTS, WANTSP
+      INTEGER            I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
+      DOUBLE PRECISION   BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
+     $                   MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+      DOUBLE PRECISION   DUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT, DLAMCH, DLAPY2, DNRM2
+      EXTERNAL           LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLACPY, DLAQTR, DTREXC, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      ELSE
+*
+*        Set M to the number of eigenpairs for which condition numbers
+*        are required, and test MM.
+*
+         IF( SOMCON ) THEN
+            M = 0
+            PAIR = .FALSE.
+            DO 10 K = 1, N
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+               ELSE
+                  IF( K.LT.N ) THEN
+                     IF( T( K+1, K ).EQ.ZERO ) THEN
+                        IF( SELECT( K ) )
+     $                     M = M + 1
+                     ELSE
+                        PAIR = .TRUE.
+                        IF( SELECT( K ) .OR. SELECT( K+1 ) )
+     $                     M = M + 2
+                     END IF
+                  ELSE
+                     IF( SELECT( N ) )
+     $                  M = M + 1
+                  END IF
+               END IF
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( MM.LT.M ) THEN
+            INFO = -13
+         ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRSNA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( 1 ) )
+     $         RETURN
+         END IF
+         IF( WANTS )
+     $      S( 1 ) = ONE
+         IF( WANTSP )
+     $      SEP( 1 ) = ABS( T( 1, 1 ) )
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+      KS = 0
+      PAIR = .FALSE.
+      DO 60 K = 1, N
+*
+*        Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+            GO TO 60
+         ELSE
+            IF( K.LT.N )
+     $         PAIR = T( K+1, K ).NE.ZERO
+         END IF
+*
+*        Determine whether condition numbers are required for the k-th
+*        eigenpair.
+*
+         IF( SOMCON ) THEN
+            IF( PAIR ) THEN
+               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+     $            GO TO 60
+            ELSE
+               IF( .NOT.SELECT( K ) )
+     $            GO TO 60
+            END IF
+         END IF
+*
+         KS = KS + 1
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            IF( .NOT.PAIR ) THEN
+*
+*              Real eigenvalue.
+*
+               PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+               RNRM = DNRM2( N, VR( 1, KS ), 1 )
+               LNRM = DNRM2( N, VL( 1, KS ), 1 )
+               S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
+            ELSE
+*
+*              Complex eigenvalue.
+*
+               PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+               PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
+     $                 1 )
+               PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
+               PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
+     $                 1 )
+               RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
+     $                DNRM2( N, VR( 1, KS+1 ), 1 ) )
+               LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
+     $                DNRM2( N, VL( 1, KS+1 ), 1 ) )
+               COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
+               S( KS ) = COND
+               S( KS+1 ) = COND
+            END IF
+         END IF
+*
+         IF( WANTSP ) THEN
+*
+*           Estimate the reciprocal condition number of the k-th
+*           eigenvector.
+*
+*           Copy the matrix T to the array WORK and swap the diagonal
+*           block beginning at T(k,k) to the (1,1) position.
+*
+            CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
+            IFST = K
+            ILST = 1
+            CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
+     $                   WORK( 1, N+1 ), IERR )
+*
+            IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+*              Could not swap because blocks not well separated
+*
+               SCALE = ONE
+               EST = BIGNUM
+            ELSE
+*
+*              Reordering successful
+*
+               IF( WORK( 2, 1 ).EQ.ZERO ) THEN
+*
+*                 Form C = T22 - lambda*I in WORK(2:N,2:N).
+*
+                  DO 20 I = 2, N
+                     WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
+   20             CONTINUE
+                  N2 = 1
+                  NN = N - 1
+               ELSE
+*
+*                 Triangularize the 2 by 2 block by unitary
+*                 transformation U = [  cs   i*ss ]
+*                                    [ i*ss   cs  ].
+*                 such that the (1,1) position of WORK is complex
+*                 eigenvalue lambda with positive imaginary part. (2,2)
+*                 position of WORK is the complex eigenvalue lambda
+*                 with negative imaginary  part.
+*
+                  MU = SQRT( ABS( WORK( 1, 2 ) ) )*
+     $                 SQRT( ABS( WORK( 2, 1 ) ) )
+                  DELTA = DLAPY2( MU, WORK( 2, 1 ) )
+                  CS = MU / DELTA
+                  SN = -WORK( 2, 1 ) / DELTA
+*
+*                 Form
+*
+*                 C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
+*                                        [   mu                     ]
+*                                        [         ..               ]
+*                                        [             ..           ]
+*                                        [                  mu      ]
+*                 where C' is conjugate transpose of complex matrix C,
+*                 and RWORK is stored starting in the N+1-st column of
+*                 WORK.
+*
+                  DO 30 J = 3, N
+                     WORK( 2, J ) = CS*WORK( 2, J )
+                     WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
+   30             CONTINUE
+                  WORK( 2, 2 ) = ZERO
+*
+                  WORK( 1, N+1 ) = TWO*MU
+                  DO 40 I = 2, N - 1
+                     WORK( I, N+1 ) = SN*WORK( 1, I+1 )
+   40             CONTINUE
+                  N2 = 2
+                  NN = 2*( N-1 )
+               END IF
+*
+*              Estimate norm(inv(C'))
+*
+               EST = ZERO
+               KASE = 0
+   50          CONTINUE
+               CALL DLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
+     $                      EST, KASE, ISAVE )
+               IF( KASE.NE.0 ) THEN
+                  IF( KASE.EQ.1 ) THEN
+                     IF( N2.EQ.1 ) THEN
+*
+*                       Real eigenvalue: solve C'*x = scale*c.
+*
+                        CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
+     $                               LDWORK, DUMMY, DUMM, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+                     ELSE
+*
+*                       Complex eigenvalue: solve
+*                       C'*(p+iq) = scale*(c+id) in real arithmetic.
+*
+                        CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
+     $                               LDWORK, WORK( 1, N+1 ), MU, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+                     END IF
+                  ELSE
+                     IF( N2.EQ.1 ) THEN
+*
+*                       Real eigenvalue: solve C*x = scale*c.
+*
+                        CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
+     $                               LDWORK, DUMMY, DUMM, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+                     ELSE
+*
+*                       Complex eigenvalue: solve
+*                       C*(p+iq) = scale*(c+id) in real arithmetic.
+*
+                        CALL DLAQTR( .FALSE., .FALSE., N-1,
+     $                               WORK( 2, 2 ), LDWORK,
+     $                               WORK( 1, N+1 ), MU, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+*
+                     END IF
+                  END IF
+*
+                  GO TO 50
+               END IF
+            END IF
+*
+            SEP( KS ) = SCALE / MAX( EST, SMLNUM )
+            IF( PAIR )
+     $         SEP( KS+1 ) = SEP( KS )
+         END IF
+*
+         IF( PAIR )
+     $      KS = KS + 1
+*
+   60 CONTINUE
+      RETURN
+*
+*     End of DTRSNA
+*
+      END
diff --git a/SRC/dtrsyl.f b/SRC/dtrsyl.f
new file mode 100644
index 00000000..4c6c28e5
--- /dev/null
+++ b/SRC/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/dtrti2.f b/SRC/dtrti2.f
new file mode 100644
index 00000000..e7ae764d
--- /dev/null
+++ b/SRC/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/dtrtri.f b/SRC/dtrtri.f
new file mode 100644
index 00000000..375813c6
--- /dev/null
+++ b/SRC/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/dtrtrs.f b/SRC/dtrtrs.f
new file mode 100644
index 00000000..139ea6d4
--- /dev/null
+++ b/SRC/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/dtzrqf.f b/SRC/dtzrqf.f
new file mode 100644
index 00000000..27f2520d
--- /dev/null
+++ b/SRC/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, DLARFP, 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 DLARFP( 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/dtzrzf.f b/SRC/dtzrzf.f
new file mode 100644
index 00000000..378eefe1
--- /dev/null
+++ b/SRC/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/dzsum1.f b/SRC/dzsum1.f
new file mode 100644
index 00000000..0b6c60e7
--- /dev/null
+++ b/SRC/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/icmax1.f b/SRC/icmax1.f
new file mode 100644
index 00000000..ef36a0e9
--- /dev/null
+++ b/SRC/icmax1.f
@@ -0,0 +1,95 @@
+      INTEGER          FUNCTION ICMAX1( 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            CX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ICMAX1 finds the index of the element whose real part has maximum
+*  absolute value.
+*
+*  Based on ICAMAX from Level 1 BLAS.
+*  The change is to use the 'genuine' absolute value.
+*
+*  Contributed by Nick Higham for use with CLACON.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vector CX.
+*
+*  CX      (input) COMPLEX array, dimension (N)
+*          The vector whose elements will be summed.
+*
+*  INCX    (input) INTEGER
+*          The spacing between successive values of CX.  INCX >= 1.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      REAL               SMAX
+      COMPLEX            ZDUM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Statement Functions ..
+      REAL               CABS1
+*     ..
+*     .. Statement Function definitions ..
+*
+*     NEXT LINE IS THE ONLY MODIFICATION.
+      CABS1( ZDUM ) = ABS( ZDUM )
+*     ..
+*     .. Executable Statements ..
+*
+      ICMAX1 = 0
+      IF( N.LT.1 )
+     $   RETURN
+      ICMAX1 = 1
+      IF( N.EQ.1 )
+     $   RETURN
+      IF( INCX.EQ.1 )
+     $   GO TO 30
+*
+*     CODE FOR INCREMENT NOT EQUAL TO 1
+*
+      IX = 1
+      SMAX = CABS1( CX( 1 ) )
+      IX = IX + INCX
+      DO 20 I = 2, N
+         IF( CABS1( CX( IX ) ).LE.SMAX )
+     $      GO TO 10
+         ICMAX1 = I
+         SMAX = CABS1( CX( IX ) )
+   10    CONTINUE
+         IX = IX + INCX
+   20 CONTINUE
+      RETURN
+*
+*     CODE FOR INCREMENT EQUAL TO 1
+*
+   30 CONTINUE
+      SMAX = CABS1( CX( 1 ) )
+      DO 40 I = 2, N
+         IF( CABS1( CX( I ) ).LE.SMAX )
+     $      GO TO 40
+         ICMAX1 = I
+         SMAX = CABS1( CX( I ) )
+   40 CONTINUE
+      RETURN
+*
+*     End of ICMAX1
+*
+      END
diff --git a/SRC/ieeeck.f b/SRC/ieeeck.f
new file mode 100644
index 00000000..ac4aff85
--- /dev/null
+++ b/SRC/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/ila_len_trim.f b/SRC/ila_len_trim.f
new file mode 100644
index 00000000..7eced971
--- /dev/null
+++ b/SRC/ila_len_trim.f
@@ -0,0 +1,42 @@
+      INTEGER FUNCTION ILA_LEN_TRIM(SUBNAM)
+C
+C  -- LAPACK auxiliary routine (version 3.1) --
+C     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+C     October 2006
+C
+C     .. Scalar Arguments ..
+      CHARACTER*(*) SUBNAM
+C     ..
+C
+C  Purpose
+C  =======
+C
+C  ILA_LEN_TRIM is called from testing and timing routines to remove
+C  trailing spaces from its argument.  It is included in the library
+C  for possible use within a user's XERBLA error-handing routine.
+C
+C  Arguments
+C  =========
+C
+C  SUBNAM  (input) CHARACTER*(*)
+C          Provides the string.
+C
+C  RETURN VALUE:  INTEGER
+C          = N > 0 : The location of the last non-blank.
+C          = 0     : The entire string is blank.
+C
+C     .. Local Scalars ..
+      INTEGER I
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC LEN
+C     ..
+
+      DO I = LEN(SUBNAM),1,-1
+          IF (SUBNAM(I:I).NE.' ') THEN
+              ILA_LEN_TRIM = I
+              RETURN
+          END IF
+      END DO
+      ILA_LEN_TRIM = 0
+      END
diff --git a/SRC/ilaclc.f b/SRC/ilaclc.f
new file mode 100644
index 00000000..019c8f55
--- /dev/null
+++ b/SRC/ilaclc.f
@@ -0,0 +1,58 @@
+      INTEGER FUNCTION ILACLC(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILACLC scans A for its last non-zero column.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  A       (input) COMPLEX array, dimension (LDA,N)
+!          The m by n matrix A.
+!
+!  LDA     (input) INTEGER
+!          The leading dimension of the array A. LDA >= max(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      COMPLEX          ZERO
+      PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILACLC = N
+      ELSE
+!     Now scan each column from the end, returning with the first non-zero.
+         DO ILACLC = N, 1, -1
+            DO I = 1, M
+               IF( A(I, ILACLC).NE.ZERO ) RETURN
+            END DO
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/ilaclr.f b/SRC/ilaclr.f
new file mode 100644
index 00000000..89d04e74
--- /dev/null
+++ b/SRC/ilaclr.f
@@ -0,0 +1,60 @@
+      INTEGER FUNCTION ILACLR(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      COMPLEX            A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILACLR scans A for its last non-zero row.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  A       (input) COMPLEX          array, dimension (LDA,N)
+!          The m by n matrix A.
+!
+!  LDA     (input) INTEGER
+!          The leading dimension of the array A. LDA >= max(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      COMPLEX          ZERO
+      PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILACLR = M
+      ELSE
+!     Scan up each column tracking the last zero row seen.
+         ILACLR = 0
+         DO J = 1, N
+            DO I = M, 1, -1
+               IF( A(I, J).NE.ZERO ) EXIT
+            END DO
+            ILACLR = MAX( ILACLR, I )
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/iladlc.f b/SRC/iladlc.f
new file mode 100644
index 00000000..fb983d6b
--- /dev/null
+++ b/SRC/iladlc.f
@@ -0,0 +1,58 @@
+      INTEGER FUNCTION ILADLC(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILADLC scans A for its last non-zero column.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  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(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      DOUBLE PRECISION ZERO
+      PARAMETER ( ZERO = 0.0D+0 )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILADLC = N
+      ELSE
+!     Now scan each column from the end, returning with the first non-zero.
+         DO ILADLC = N, 1, -1
+            DO I = 1, M
+               IF( A(I, ILADLC).NE.ZERO ) RETURN
+            END DO
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/iladlr.f b/SRC/iladlr.f
new file mode 100644
index 00000000..94dfe051
--- /dev/null
+++ b/SRC/iladlr.f
@@ -0,0 +1,60 @@
+      INTEGER FUNCTION ILADLR(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILADLR scans A for its last non-zero row.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  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(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      DOUBLE PRECISION ZERO
+      PARAMETER ( ZERO = 0.0D+0 )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILADLR = M
+      ELSE
+!     Scan up each column tracking the last zero row seen.
+         ILADLR = 0
+         DO J = 1, N
+            DO I = M, 1, -1
+               IF( A(I, J).NE.ZERO ) EXIT
+            END DO
+            ILADLR = MAX( ILADLR, I )
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f
new file mode 100644
index 00000000..b0d2c005
--- /dev/null
+++ b/SRC/ilaenv.f
@@ -0,0 +1,552 @@
+      INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+*
+*  -- LAPACK auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. 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.
+*
+*  ILAENV returns an INTEGER
+*  if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
+*  if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value.
+*
+*  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.
+*
+*  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( 1, 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( 0, 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/ilaslc.f b/SRC/ilaslc.f
new file mode 100644
index 00000000..438dee61
--- /dev/null
+++ b/SRC/ilaslc.f
@@ -0,0 +1,58 @@
+      INTEGER FUNCTION ILASLC(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      REAL               A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILASLC scans A for its last non-zero column.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  A       (input) REAL array, dimension (LDA,N)
+!          The m by n matrix A.
+!
+!  LDA     (input) INTEGER
+!          The leading dimension of the array A. LDA >= max(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      REAL             ZERO
+      PARAMETER ( ZERO = 0.0D+0 )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILASLC = N
+      ELSE
+!     Now scan each column from the end, returning with the first non-zero.
+         DO ILASLC = N, 1, -1
+            DO I = 1, M
+               IF( A(I, ILASLC).NE.ZERO ) RETURN
+            END DO
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/ilaslr.f b/SRC/ilaslr.f
new file mode 100644
index 00000000..dceb68a3
--- /dev/null
+++ b/SRC/ilaslr.f
@@ -0,0 +1,60 @@
+      INTEGER FUNCTION ILASLR(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      REAL               A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILASLR scans A for its last non-zero row.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  A       (input) REAL             array, dimension (LDA,N)
+!          The m by n matrix A.
+!
+!  LDA     (input) INTEGER
+!          The leading dimension of the array A. LDA >= max(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      REAL             ZERO
+      PARAMETER ( ZERO = 0.0E+0 )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILASLR = M
+      ELSE
+!     Scan up each column tracking the last zero row seen.
+         ILASLR = 0
+         DO J = 1, N
+            DO I = M, 1, -1
+               IF( A(I, J).NE.ZERO ) EXIT
+            END DO
+            ILASLR = MAX( ILASLR, I )
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/ilaver.f b/SRC/ilaver.f
new file mode 100644
index 00000000..10ef35de
--- /dev/null
+++ b/SRC/ilaver.f
@@ -0,0 +1,31 @@
+      SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+*     
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine return the Lapack version
+*
+*  Arguments
+*  =========
+*  VERS_MAJOR   (output) INTEGER
+*      return the lapack major version
+*  VERS_MINOR   (output) INTEGER
+*      return the lapack minor version from the major version
+*  VERS_PATCH   (output) INTEGER
+*      return the lapack patch version from the minor version
+*  =====================================================================
+*
+      INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
+*  =====================================================================
+      VERS_MAJOR = 3
+      VERS_MINOR = 1
+      VERS_PATCH = 1
+*  =====================================================================
+*
+      RETURN
+      END
diff --git a/SRC/ilazlc.f b/SRC/ilazlc.f
new file mode 100644
index 00000000..2d8718e1
--- /dev/null
+++ b/SRC/ilazlc.f
@@ -0,0 +1,58 @@
+      INTEGER FUNCTION ILAZLC(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILAZLC scans A for its last non-zero column.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  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(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      COMPLEX*16       ZERO
+      PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILAZLC = N
+      ELSE
+!     Now scan each column from the end, returning with the first non-zero.
+         DO ILAZLC = N, 1, -1
+            DO I = 1, M
+               IF( A(I, ILAZLC).NE.ZERO ) RETURN
+            END DO
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/ilazlr.f b/SRC/ilazlr.f
new file mode 100644
index 00000000..8f88cc9a
--- /dev/null
+++ b/SRC/ilazlr.f
@@ -0,0 +1,60 @@
+      INTEGER FUNCTION ILAZLR(M, N, A, LDA)
+      IMPLICIT NONE
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     December 2007
+!
+!     .. Scalar Arguments ..
+      INTEGER            M, N, LDA
+!     ..
+!     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  ILAZLR scans A for its last non-zero row.
+!
+!  Arguments
+!  =========
+!
+!  M       (input) INTEGER
+!          The number of rows of the matrix A.
+!
+!  N       (input) INTEGER
+!          The number of columns of the matrix A.
+!
+!  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(1,M).
+!
+!  =====================================================================
+!
+!     .. Parameters ..
+      COMPLEX*16       ZERO
+      PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
+!     ..
+!     .. Local Scalars ..
+      INTEGER I, J
+!     ..
+!     .. Executable Statements ..
+!
+!     Quick test for the common case where one corner is non-zero.
+      IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+         ILAZLR = M
+      ELSE
+!     Scan up each column tracking the last zero row seen.
+         ILAZLR = 0
+         DO J = 1, N
+            DO I = M, 1, -1
+               IF( A(I, J).NE.ZERO ) EXIT
+            END DO
+            ILAZLR = MAX( ILAZLR, I )
+         END DO
+      END IF
+      RETURN
+      END FUNCTION
diff --git a/SRC/iparmq.f b/SRC/iparmq.f
new file mode 100644
index 00000000..d9d0af36
--- /dev/null
+++ b/SRC/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/izmax1.f b/SRC/izmax1.f
new file mode 100644
index 00000000..7ebffee3
--- /dev/null
+++ b/SRC/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/lsamen.f b/SRC/lsamen.f
new file mode 100644
index 00000000..d64dc0e0
--- /dev/null
+++ b/SRC/lsamen.f
@@ -0,0 +1,67 @@
+      LOGICAL          FUNCTION LSAMEN( N, CA, CB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER*( * )    CA, CB
+      INTEGER            N
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  LSAMEN  tests if the first N letters of CA are the same as the
+*  first N letters of CB, regardless of case.
+*  LSAMEN returns .TRUE. if CA and CB are equivalent except for case
+*  and .FALSE. otherwise.  LSAMEN also returns .FALSE. if LEN( CA )
+*  or LEN( CB ) is less than N.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of characters in CA and CB to be compared.
+*
+*  CA      (input) CHARACTER*(*)
+*  CB      (input) CHARACTER*(*)
+*          CA and CB specify two character strings of length at least N.
+*          Only the first N characters of each string will be accessed.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          LEN
+*     ..
+*     .. Executable Statements ..
+*
+      LSAMEN = .FALSE.
+      IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N )
+     $   GO TO 20
+*
+*     Do for each character in the two strings.
+*
+      DO 10 I = 1, N
+*
+*        Test if the characters are equal using LSAME.
+*
+         IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) )
+     $      GO TO 20
+*
+   10 CONTINUE
+      LSAMEN = .TRUE.
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of LSAMEN
+*
+      END
diff --git a/SRC/sbdsdc.f b/SRC/sbdsdc.f
new file mode 100644
index 00000000..3048b483
--- /dev/null
+++ b/SRC/sbdsdc.f
@@ -0,0 +1,428 @@
+      SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, UPLO
+      INTEGER            INFO, LDU, LDVT, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IQ( * ), IWORK( * )
+      REAL               D( * ), E( * ), Q( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SBDSDC computes the singular value decomposition (SVD) of a real
+*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
+*  using a divide and conquer method, where S is a diagonal matrix
+*  with non-negative diagonal elements (the singular values of B), and
+*  U and VT are orthogonal matrices of left and right singular vectors,
+*  respectively. SBDSDC can be used to compute all singular values,
+*  and optionally, singular vectors or singular vectors in compact form.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.  See SLASD3 for details.
+*
+*  The code currently calls SLASDQ if singular values only are desired.
+*  However, it can be slightly modified to compute singular values
+*  using the divide and conquer method.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  B is upper bidiagonal.
+*          = 'L':  B is lower bidiagonal.
+*
+*  COMPQ   (input) CHARACTER*1
+*          Specifies whether singular vectors are to be computed
+*          as follows:
+*          = 'N':  Compute singular values only;
+*          = 'P':  Compute singular values and compute singular
+*                  vectors in compact form;
+*          = 'I':  Compute singular values and singular vectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrix B.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the bidiagonal matrix B.
+*          On exit, if INFO=0, the singular values of B.
+*
+*  E       (input/output) REAL array, dimension (N-1)
+*          On entry, the elements of E contain the offdiagonal
+*          elements of the bidiagonal matrix whose SVD is desired.
+*          On exit, E has been destroyed.
+*
+*  U       (output) REAL array, dimension (LDU,N)
+*          If  COMPQ = 'I', then:
+*             On exit, if INFO = 0, U contains the left singular vectors
+*             of the bidiagonal matrix.
+*          For other values of COMPQ, U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1.
+*          If singular vectors are desired, then LDU >= max( 1, N ).
+*
+*  VT      (output) REAL array, dimension (LDVT,N)
+*          If  COMPQ = 'I', then:
+*             On exit, if INFO = 0, VT' contains the right singular
+*             vectors of the bidiagonal matrix.
+*          For other values of COMPQ, VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1.
+*          If singular vectors are desired, then LDVT >= max( 1, N ).
+*
+*  Q       (output) REAL array, dimension (LDQ)
+*          If  COMPQ = 'P', then:
+*             On exit, if INFO = 0, Q and IQ contain the left
+*             and right singular vectors in a compact form,
+*             requiring O(N log N) space instead of 2*N**2.
+*             In particular, Q contains all the REAL data in
+*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
+*             words of memory, where SMLSIZ is returned by ILAENV and
+*             is equal to the maximum size of the subproblems at the
+*             bottom of the computation tree (usually about 25).
+*          For other values of COMPQ, Q is not referenced.
+*
+*  IQ      (output) INTEGER array, dimension (LDIQ)
+*          If  COMPQ = 'P', then:
+*             On exit, if INFO = 0, Q and IQ contain the left
+*             and right singular vectors in a compact form,
+*             requiring O(N log N) space instead of 2*N**2.
+*             In particular, IQ contains all INTEGER data in
+*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
+*             words of memory, where SMLSIZ is returned by ILAENV and
+*             is equal to the maximum size of the subproblems at the
+*             bottom of the computation tree (usually about 25).
+*          For other values of COMPQ, IQ is not referenced.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK))
+*          If COMPQ = 'N' then LWORK >= (4 * N).
+*          If COMPQ = 'P' then LWORK >= (6 * N).
+*          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
+*
+*  IWORK   (workspace) INTEGER array, dimension (8*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an singular value.
+*                The update process of divide and conquer failed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*  =====================================================================
+*  Changed dimension statement in comment describing E from (N) to
+*  (N-1).  Sven, 17 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
+     $                   ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
+     $                   MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
+     $                   SMLSZP, SQRE, START, WSTART, Z
+      REAL               CS, EPS, ORGNRM, P, R, SN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANST
+      EXTERNAL           SLAMCH, SLANST, ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLARTG, SLASCL, SLASD0, SLASDA, SLASDQ,
+     $                   SLASET, SLASR, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          REAL, ABS, INT, LOG, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IUPLO = 0
+      IF( LSAME( UPLO, 'U' ) )
+     $   IUPLO = 1
+      IF( LSAME( UPLO, 'L' ) )
+     $   IUPLO = 2
+      IF( LSAME( COMPQ, 'N' ) ) THEN
+         ICOMPQ = 0
+      ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
+         ICOMPQ = 1
+      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+         ICOMPQ = 2
+      ELSE
+         ICOMPQ = -1
+      END IF
+      IF( IUPLO.EQ.0 ) THEN
+         INFO = -1
+      ELSE IF( ICOMPQ.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
+     $         N ) ) ) THEN
+         INFO = -7
+      ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
+     $         N ) ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SBDSDC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      SMLSIZ = ILAENV( 9, 'SBDSDC', ' ', 0, 0, 0, 0 )
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPQ.EQ.1 ) THEN
+            Q( 1 ) = SIGN( ONE, D( 1 ) )
+            Q( 1+SMLSIZ*N ) = ONE
+         ELSE IF( ICOMPQ.EQ.2 ) THEN
+            U( 1, 1 ) = SIGN( ONE, D( 1 ) )
+            VT( 1, 1 ) = ONE
+         END IF
+         D( 1 ) = ABS( D( 1 ) )
+         RETURN
+      END IF
+      NM1 = N - 1
+*
+*     If matrix lower bidiagonal, rotate to be upper bidiagonal
+*     by applying Givens rotations on the left
+*
+      WSTART = 1
+      QSTART = 3
+      IF( ICOMPQ.EQ.1 ) THEN
+         CALL SCOPY( N, D, 1, Q( 1 ), 1 )
+         CALL SCOPY( N-1, E, 1, Q( N+1 ), 1 )
+      END IF
+      IF( IUPLO.EQ.2 ) THEN
+         QSTART = 5
+         WSTART = 2*N - 1
+         DO 10 I = 1, N - 1
+            CALL SLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( ICOMPQ.EQ.1 ) THEN
+               Q( I+2*N ) = CS
+               Q( I+3*N ) = SN
+            ELSE IF( ICOMPQ.EQ.2 ) THEN
+               WORK( I ) = CS
+               WORK( NM1+I ) = -SN
+            END IF
+   10    CONTINUE
+      END IF
+*
+*     If ICOMPQ = 0, use SLASDQ to compute the singular values.
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+         CALL SLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
+     $                LDU, WORK( WSTART ), INFO )
+         GO TO 40
+      END IF
+*
+*     If N is smaller than the minimum divide size SMLSIZ, then solve
+*     the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         IF( ICOMPQ.EQ.2 ) THEN
+            CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
+            CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+            CALL SLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
+     $                   LDU, WORK( WSTART ), INFO )
+         ELSE IF( ICOMPQ.EQ.1 ) THEN
+            IU = 1
+            IVT = IU + N
+            CALL SLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
+     $                   N )
+            CALL SLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
+     $                   N )
+            CALL SLASDQ( 'U', 0, N, N, N, 0, D, E,
+     $                   Q( IVT+( QSTART-1 )*N ), N,
+     $                   Q( IU+( QSTART-1 )*N ), N,
+     $                   Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
+     $                   INFO )
+         END IF
+         GO TO 40
+      END IF
+*
+      IF( ICOMPQ.EQ.2 ) THEN
+         CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
+         CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+      END IF
+*
+*     Scale.
+*
+      ORGNRM = SLANST( 'M', N, D, E )
+      IF( ORGNRM.EQ.ZERO )
+     $   RETURN
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
+*
+      EPS = SLAMCH( 'Epsilon' )
+*
+      MLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+      SMLSZP = SMLSIZ + 1
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         IU = 1
+         IVT = 1 + SMLSIZ
+         DIFL = IVT + SMLSZP
+         DIFR = DIFL + MLVL
+         Z = DIFR + MLVL*2
+         IC = Z + MLVL
+         IS = IC + 1
+         POLES = IS + 1
+         GIVNUM = POLES + 2*MLVL
+*
+         K = 1
+         GIVPTR = 2
+         PERM = 3
+         GIVCOL = PERM + MLVL
+      END IF
+*
+      DO 20 I = 1, N
+         IF( ABS( D( I ) ).LT.EPS ) THEN
+            D( I ) = SIGN( EPS, D( I ) )
+         END IF
+   20 CONTINUE
+*
+      START = 1
+      SQRE = 0
+*
+      DO 30 I = 1, NM1
+         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+*
+*        Subproblem found. First determine its size and then
+*        apply divide and conquer on it.
+*
+            IF( I.LT.NM1 ) THEN
+*
+*        A subproblem with E(I) small for I < NM1.
+*
+               NSIZE = I - START + 1
+            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+*        A subproblem with E(NM1) not too small but I = NM1.
+*
+               NSIZE = N - START + 1
+            ELSE
+*
+*        A subproblem with E(NM1) small. This implies an
+*        1-by-1 subproblem at D(N). Solve this 1-by-1 problem
+*        first.
+*
+               NSIZE = I - START + 1
+               IF( ICOMPQ.EQ.2 ) THEN
+                  U( N, N ) = SIGN( ONE, D( N ) )
+                  VT( N, N ) = ONE
+               ELSE IF( ICOMPQ.EQ.1 ) THEN
+                  Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
+                  Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
+               END IF
+               D( N ) = ABS( D( N ) )
+            END IF
+            IF( ICOMPQ.EQ.2 ) THEN
+               CALL SLASD0( NSIZE, SQRE, D( START ), E( START ),
+     $                      U( START, START ), LDU, VT( START, START ),
+     $                      LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
+            ELSE
+               CALL SLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
+     $                      E( START ), Q( START+( IU+QSTART-2 )*N ), N,
+     $                      Q( START+( IVT+QSTART-2 )*N ),
+     $                      IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
+     $                      N ), Q( START+( DIFR+QSTART-2 )*N ),
+     $                      Q( START+( Z+QSTART-2 )*N ),
+     $                      Q( START+( POLES+QSTART-2 )*N ),
+     $                      IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
+     $                      N, IQ( START+PERM*N ),
+     $                      Q( START+( GIVNUM+QSTART-2 )*N ),
+     $                      Q( START+( IC+QSTART-2 )*N ),
+     $                      Q( START+( IS+QSTART-2 )*N ),
+     $                      WORK( WSTART ), IWORK, INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+            END IF
+            START = I + 1
+         END IF
+   30 CONTINUE
+*
+*     Unscale
+*
+      CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
+   40 CONTINUE
+*
+*     Use Selection Sort to minimize swaps of singular vectors
+*
+      DO 60 II = 2, N
+         I = II - 1
+         KK = I
+         P = D( I )
+         DO 50 J = II, N
+            IF( D( J ).GT.P ) THEN
+               KK = J
+               P = D( J )
+            END IF
+   50    CONTINUE
+         IF( KK.NE.I ) THEN
+            D( KK ) = D( I )
+            D( I ) = P
+            IF( ICOMPQ.EQ.1 ) THEN
+               IQ( I ) = KK
+            ELSE IF( ICOMPQ.EQ.2 ) THEN
+               CALL SSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
+               CALL SSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
+            END IF
+         ELSE IF( ICOMPQ.EQ.1 ) THEN
+            IQ( I ) = I
+         END IF
+   60 CONTINUE
+*
+*     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         IF( IUPLO.EQ.1 ) THEN
+            IQ( N ) = 1
+         ELSE
+            IQ( N ) = 0
+         END IF
+      END IF
+*
+*     If B is lower bidiagonal, update U by those Givens rotations
+*     which rotated B to be upper bidiagonal
+*
+      IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
+     $   CALL SLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
+*
+      RETURN
+*
+*     End of SBDSDC
+*
+      END
diff --git a/SRC/sbdsqr.f b/SRC/sbdsqr.f
new file mode 100644
index 00000000..40339577
--- /dev/null
+++ b/SRC/sbdsqr.f
@@ -0,0 +1,742 @@
+      SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+     $                   LDU, C, LDC, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
+*     ..
+*     .. Array Arguments ..
+      REAL               C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SBDSQR 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 SGEBRD, 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension (2*N)
+*          if NCVT = NRU = NCC = 0, (max(1, 4*N)) 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  REAL, 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               NEGONE
+      PARAMETER          ( NEGONE = -1.0E0 )
+      REAL               HNDRTH
+      PARAMETER          ( HNDRTH = 0.01E0 )
+      REAL               TEN
+      PARAMETER          ( TEN = 10.0E0 )
+      REAL               HNDRD
+      PARAMETER          ( HNDRD = 100.0E0 )
+      REAL               MEIGTH
+      PARAMETER          ( MEIGTH = -0.125E0 )
+      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
+      REAL               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
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARTG, SLAS2, SLASQ1, SLASR, SLASV2, SROT,
+     $                   SSCAL, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, 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( 'SBDSQR', -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 SLASQ1( N, D, E, WORK, INFO )
+         RETURN
+      END IF
+*
+      NM1 = N - 1
+      NM12 = NM1 + NM1
+      NM13 = NM12 + NM1
+      IDIR = 0
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'Epsilon' )
+      UNFL = SLAMCH( '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 SLARTG( 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 SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
+     $                  LDU )
+         IF( NCC.GT.0 )
+     $      CALL SLASR( '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( REAL( 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 SLASV2( 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 SROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
+     $                 SINR )
+         IF( NRU.GT.0 )
+     $      CALL SROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
+         IF( NCC.GT.0 )
+     $      CALL SROT( 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 SLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
+         ELSE
+            SLL = ABS( D( M ) )
+            CALL SLAS2( 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 SLARTG( D( I )*CS, E( I ), CS, SN, R )
+               IF( I.GT.LL )
+     $            E( I-1 ) = OLDSN*R
+               CALL SLARTG( 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 SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+     $                     WORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL SLASR( '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 SLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+               IF( I.LT.M )
+     $            E( I ) = OLDSN*R
+               CALL SLARTG( 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 SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+     $                     WORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL SLASR( '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 SLARTG( 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 SLARTG( 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 SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+     $                     WORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL SLASR( '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 SLARTG( 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 SLARTG( 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 SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+     $                     WORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL SLASR( '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 SSCAL( 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 SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
+     $                     LDVT )
+            IF( NRU.GT.0 )
+     $         CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL SSWAP( 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 SBDSQR
+*
+      END
diff --git a/SRC/scsum1.f b/SRC/scsum1.f
new file mode 100644
index 00000000..ac7ef369
--- /dev/null
+++ b/SRC/scsum1.f
@@ -0,0 +1,81 @@
+      REAL             FUNCTION SCSUM1( 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            CX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SCSUM1 takes the sum of the absolute values of a complex
+*  vector and returns a single precision result.
+*
+*  Based on SCASUM from the Level 1 BLAS.
+*  The change is to use the 'genuine' absolute value.
+*
+*  Contributed by Nick Higham for use with CLACON.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vector CX.
+*
+*  CX      (input) COMPLEX array, dimension (N)
+*          The vector whose elements will be summed.
+*
+*  INCX    (input) INTEGER
+*          The spacing between successive values of CX.  INCX > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, NINCX
+      REAL               STEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      SCSUM1 = 0.0E0
+      STEMP = 0.0E0
+      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
+      SCSUM1 = 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
+      SCSUM1 = STEMP
+      RETURN
+*
+*     End of SCSUM1
+*
+      END
diff --git a/SRC/sdisna.f b/SRC/sdisna.f
new file mode 100644
index 00000000..ef9cd15d
--- /dev/null
+++ b/SRC/sdisna.f
@@ -0,0 +1,179 @@
+      SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB
+      INTEGER            INFO, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), SEP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SDISNA computes the reciprocal condition numbers for the eigenvectors
+*  of a real symmetric or complex Hermitian matrix or for the left or
+*  right singular vectors of a general m-by-n matrix. The reciprocal
+*  condition number is the 'gap' between the corresponding eigenvalue or
+*  singular value and the nearest other one.
+*
+*  The bound on the error, measured by angle in radians, in the I-th
+*  computed vector is given by
+*
+*         SLAMCH( 'E' ) * ( ANORM / SEP( I ) )
+*
+*  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed
+*  to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of
+*  the error bound.
+*
+*  SDISNA may also be used to compute error bounds for eigenvectors of
+*  the generalized symmetric definite eigenproblem.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies for which problem the reciprocal condition numbers
+*          should be computed:
+*          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;
+*          = 'L':  the left singular vectors of a general matrix;
+*          = 'R':  the right singular vectors of a general matrix.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix. M >= 0.
+*
+*  N       (input) INTEGER
+*          If JOB = 'L' or 'R', the number of columns of the matrix,
+*          in which case N >= 0. Ignored if JOB = 'E'.
+*
+*  D       (input) REAL array, dimension (M) if JOB = 'E'
+*                              dimension (min(M,N)) if JOB = 'L' or 'R'
+*          The eigenvalues (if JOB = 'E') or singular values (if JOB =
+*          'L' or 'R') of the matrix, in either increasing or decreasing
+*          order. If singular values, they must be non-negative.
+*
+*  SEP     (output) REAL array, dimension (M) if JOB = 'E'
+*                               dimension (min(M,N)) if JOB = 'L' or 'R'
+*          The reciprocal condition numbers of the vectors.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DECR, EIGEN, INCR, LEFT, RIGHT, SING
+      INTEGER            I, K
+      REAL               ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      EIGEN = LSAME( JOB, 'E' )
+      LEFT = LSAME( JOB, 'L' )
+      RIGHT = LSAME( JOB, 'R' )
+      SING = LEFT .OR. RIGHT
+      IF( EIGEN ) THEN
+         K = M
+      ELSE IF( SING ) THEN
+         K = MIN( M, N )
+      END IF
+      IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 ) THEN
+         INFO = -3
+      ELSE
+         INCR = .TRUE.
+         DECR = .TRUE.
+         DO 10 I = 1, K - 1
+            IF( INCR )
+     $         INCR = INCR .AND. D( I ).LE.D( I+1 )
+            IF( DECR )
+     $         DECR = DECR .AND. D( I ).GE.D( I+1 )
+   10    CONTINUE
+         IF( SING .AND. K.GT.0 ) THEN
+            IF( INCR )
+     $         INCR = INCR .AND. ZERO.LE.D( 1 )
+            IF( DECR )
+     $         DECR = DECR .AND. D( K ).GE.ZERO
+         END IF
+         IF( .NOT.( INCR .OR. DECR ) )
+     $      INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SDISNA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 )
+     $   RETURN
+*
+*     Compute reciprocal condition numbers
+*
+      IF( K.EQ.1 ) THEN
+         SEP( 1 ) = SLAMCH( 'O' )
+      ELSE
+         OLDGAP = ABS( D( 2 )-D( 1 ) )
+         SEP( 1 ) = OLDGAP
+         DO 20 I = 2, K - 1
+            NEWGAP = ABS( D( I+1 )-D( I ) )
+            SEP( I ) = MIN( OLDGAP, NEWGAP )
+            OLDGAP = NEWGAP
+   20    CONTINUE
+         SEP( K ) = OLDGAP
+      END IF
+      IF( SING ) THEN
+         IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
+            IF( INCR )
+     $         SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
+            IF( DECR )
+     $         SEP( K ) = MIN( SEP( K ), D( K ) )
+         END IF
+      END IF
+*
+*     Ensure that reciprocal condition numbers are not less than
+*     threshold, in order to limit the size of the error bound
+*
+      EPS = SLAMCH( 'E' )
+      SAFMIN = SLAMCH( 'S' )
+      ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
+      IF( ANORM.EQ.ZERO ) THEN
+         THRESH = EPS
+      ELSE
+         THRESH = MAX( EPS*ANORM, SAFMIN )
+      END IF
+      DO 30 I = 1, K
+         SEP( I ) = MAX( SEP( I ), THRESH )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of SDISNA
+*
+      END
diff --git a/SRC/sgbbrd.f b/SRC/sgbbrd.f
new file mode 100644
index 00000000..7942421c
--- /dev/null
+++ b/SRC/sgbbrd.f
@@ -0,0 +1,443 @@
+      SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
+     $                   LDQ, PT, LDPT, C, LDC, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),
+     $                   PT( LDPT, * ), Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBBRD reduces a real general m-by-n band matrix A to upper
+*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+*  The routine computes B, and optionally forms Q or P', or computes
+*  Q'*C for a given matrix C.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          Specifies whether or not the matrices Q and P' are to be
+*          formed.
+*          = 'N': do not form Q or P';
+*          = 'Q': form Q only;
+*          = 'P': form P' only;
+*          = 'B': form both.
+*
+*  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.
+*
+*  NCC     (input) INTEGER
+*          The number of columns of the matrix C.  NCC >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals of the matrix A. KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals of the matrix A. KU >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the m-by-n band matrix A, stored in rows 1 to
+*          KL+KU+1. The j-th column of A is stored in the j-th column of
+*          the array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*          On exit, A is overwritten by values generated during the
+*          reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A. LDAB >= KL+KU+1.
+*
+*  D       (output) REAL array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B.
+*
+*  E       (output) REAL array, dimension (min(M,N)-1)
+*          The superdiagonal elements of the bidiagonal matrix B.
+*
+*  Q       (output) REAL array, dimension (LDQ,M)
+*          If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
+*          If VECT = 'N' or 'P', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
+*
+*  PT      (output) REAL array, dimension (LDPT,N)
+*          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
+*          If VECT = 'N' or 'Q', the array PT is not referenced.
+*
+*  LDPT    (input) INTEGER
+*          The leading dimension of the array PT.
+*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
+*
+*  C       (input/output) REAL array, dimension (LDC,NCC)
+*          On entry, an m-by-ncc matrix C.
+*          On exit, C is overwritten by Q'*C.
+*          C is not referenced if NCC = 0.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C.
+*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
+*
+*  WORK    (workspace) REAL array, dimension (2*max(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTB, WANTC, WANTPT, WANTQ
+      INTEGER            I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
+     $                   KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
+      REAL               RA, RB, RC, RS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARGV, SLARTG, SLARTV, SLASET, SROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTB = LSAME( VECT, 'B' )
+      WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
+      WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
+      WANTC = NCC.GT.0
+      KLU1 = KL + KU + 1
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KLU1 ) THEN
+         INFO = -8
+      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
+         INFO = -12
+      ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBBRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and P' to the unit matrix, if needed
+*
+      IF( WANTQ )
+     $   CALL SLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
+      IF( WANTPT )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      MINMN = MIN( M, N )
+*
+      IF( KL+KU.GT.1 ) THEN
+*
+*        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
+*        first to lower bidiagonal form and then transform to upper
+*        bidiagonal
+*
+         IF( KU.GT.0 ) THEN
+            ML0 = 1
+            MU0 = 2
+         ELSE
+            ML0 = 2
+            MU0 = 1
+         END IF
+*
+*        Wherever possible, plane rotations are generated and applied in
+*        vector operations of length NR over the index set J1:J2:KLU1.
+*
+*        The sines of the plane rotations are stored in WORK(1:max(m,n))
+*        and the cosines in WORK(max(m,n)+1:2*max(m,n)).
+*
+         MN = MAX( M, N )
+         KLM = MIN( M-1, KL )
+         KUN = MIN( N-1, KU )
+         KB = KLM + KUN
+         KB1 = KB + 1
+         INCA = KB1*LDAB
+         NR = 0
+         J1 = KLM + 2
+         J2 = 1 - KUN
+*
+         DO 90 I = 1, MINMN
+*
+*           Reduce i-th column and i-th row of matrix to bidiagonal form
+*
+            ML = KLM + 1
+            MU = KUN + 1
+            DO 80 KK = 1, KB
+               J1 = J1 + KB
+               J2 = J2 + KB
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been created below the band
+*
+               IF( NR.GT.0 )
+     $            CALL SLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
+     $                         WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
+*
+*              apply plane rotations from the left
+*
+               DO 10 L = 1, KB
+                  IF( J2-KLM+L-1.GT.N ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL SLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
+     $                            AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
+     $                            WORK( MN+J1 ), WORK( J1 ), KB1 )
+   10          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  IF( ML.LE.M-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i+ml-1,i)
+*                    within the band, and apply rotation from the left
+*
+                     CALL SLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
+     $                            WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
+     $                            RA )
+                     AB( KU+ML-1, I ) = RA
+                     IF( I.LT.N )
+     $                  CALL SROT( MIN( KU+ML-2, N-I ),
+     $                             AB( KU+ML-2, I+1 ), LDAB-1,
+     $                             AB( KU+ML-1, I+1 ), LDAB-1,
+     $                             WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTQ ) THEN
+*
+*                 accumulate product of plane rotations in Q
+*
+                  DO 20 J = J1, J2, KB1
+                     CALL SROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                          WORK( MN+J ), WORK( J ) )
+   20             CONTINUE
+               END IF
+*
+               IF( WANTC ) THEN
+*
+*                 apply plane rotations to C
+*
+                  DO 30 J = J1, J2, KB1
+                     CALL SROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
+     $                          WORK( MN+J ), WORK( J ) )
+   30             CONTINUE
+               END IF
+*
+               IF( J2+KUN.GT.N ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 40 J = J1, J2, KB1
+*
+*                 create nonzero element a(j-1,j+ku) above the band
+*                 and store it in WORK(n+1:2*n)
+*
+                  WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
+                  AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
+   40          CONTINUE
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been generated above the band
+*
+               IF( NR.GT.0 )
+     $            CALL SLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
+     $                         WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
+     $                         KB1 )
+*
+*              apply plane rotations from the right
+*
+               DO 50 L = 1, KB
+                  IF( J2+L-1.GT.M ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL SLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
+     $                            AB( L, J1+KUN ), INCA,
+     $                            WORK( MN+J1+KUN ), WORK( J1+KUN ),
+     $                            KB1 )
+   50          CONTINUE
+*
+               IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
+                  IF( MU.LE.N-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i,i+mu-1)
+*                    within the band, and apply rotation from the right
+*
+                     CALL SLARTG( AB( KU-MU+3, I+MU-2 ),
+     $                            AB( KU-MU+2, I+MU-1 ),
+     $                            WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
+     $                            RA )
+                     AB( KU-MU+3, I+MU-2 ) = RA
+                     CALL SROT( MIN( KL+MU-2, M-I ),
+     $                          AB( KU-MU+4, I+MU-2 ), 1,
+     $                          AB( KU-MU+3, I+MU-1 ), 1,
+     $                          WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTPT ) THEN
+*
+*                 accumulate product of plane rotations in P'
+*
+                  DO 60 J = J1, J2, KB1
+                     CALL SROT( N, PT( J+KUN-1, 1 ), LDPT,
+     $                          PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),
+     $                          WORK( J+KUN ) )
+   60             CONTINUE
+               END IF
+*
+               IF( J2+KB.GT.M ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 70 J = J1, J2, KB1
+*
+*                 create nonzero element a(j+kl+ku,j+ku-1) below the
+*                 band and store it in WORK(1:n)
+*
+                  WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
+                  AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
+   70          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  ML = ML - 1
+               ELSE
+                  MU = MU - 1
+               END IF
+   80       CONTINUE
+   90    CONTINUE
+      END IF
+*
+      IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
+*
+*        A has been reduced to lower bidiagonal form
+*
+*        Transform lower bidiagonal form to upper bidiagonal by applying
+*        plane rotations from the left, storing diagonal elements in D
+*        and off-diagonal elements in E
+*
+         DO 100 I = 1, MIN( M-1, N )
+            CALL SLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
+            D( I ) = RA
+            IF( I.LT.N ) THEN
+               E( I ) = RS*AB( 1, I+1 )
+               AB( 1, I+1 ) = RC*AB( 1, I+1 )
+            END IF
+            IF( WANTQ )
+     $         CALL SROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
+            IF( WANTC )
+     $         CALL SROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
+     $                    RS )
+  100    CONTINUE
+         IF( M.LE.N )
+     $      D( M ) = AB( 1, M )
+      ELSE IF( KU.GT.0 ) THEN
+*
+*        A has been reduced to upper bidiagonal form
+*
+         IF( M.LT.N ) THEN
+*
+*           Annihilate a(m,m+1) by applying plane rotations from the
+*           right, storing diagonal elements in D and off-diagonal
+*           elements in E
+*
+            RB = AB( KU, M+1 )
+            DO 110 I = M, 1, -1
+               CALL SLARTG( AB( KU+1, I ), RB, RC, RS, RA )
+               D( I ) = RA
+               IF( I.GT.1 ) THEN
+                  RB = -RS*AB( KU, I )
+                  E( I-1 ) = RC*AB( KU, I )
+               END IF
+               IF( WANTPT )
+     $            CALL SROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
+     $                       RC, RS )
+  110       CONTINUE
+         ELSE
+*
+*           Copy off-diagonal elements to E and diagonal elements to D
+*
+            DO 120 I = 1, MINMN - 1
+               E( I ) = AB( KU, I+1 )
+  120       CONTINUE
+            DO 130 I = 1, MINMN
+               D( I ) = AB( KU+1, I )
+  130       CONTINUE
+         END IF
+      ELSE
+*
+*        A is diagonal. Set elements of E to zero and copy diagonal
+*        elements to D.
+*
+         DO 140 I = 1, MINMN - 1
+            E( I ) = ZERO
+  140    CONTINUE
+         DO 150 I = 1, MINMN
+            D( I ) = AB( 1, I )
+  150    CONTINUE
+      END IF
+      RETURN
+*
+*     End of SGBBRD
+*
+      END
diff --git a/SRC/sgbcon.f b/SRC/sgbcon.f
new file mode 100644
index 00000000..ae688a2b
--- /dev/null
+++ b/SRC/sgbcon.f
@@ -0,0 +1,226 @@
+      SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, KL, KU, LDAB, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBCON estimates the reciprocal of the condition number of a real
+*  general band matrix A, in either the 1-norm or the infinity-norm,
+*  using the LU factorization computed by SGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by SGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= N, row i of the matrix was
+*          interchanged with row IPIV(i).
+*
+*  ANORM   (input) REAL
+*          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) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LNOTI, ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, J, JP, KASE, KASE1, KD, LM
+      REAL               AINVNM, SCALE, SMLNUM, T
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SDOT, SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SLACN2, SLATBS, SRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the norm of inv(A).
+*
+      AINVNM = ZERO
+      NORMIN = 'N'
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KD = KL + KU + 1
+      LNOTI = KL.GT.0
+      KASE = 0
+   10 CONTINUE
+      CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            IF( LNOTI ) THEN
+               DO 20 J = 1, N - 1
+                  LM = MIN( KL, N-J )
+                  JP = IPIV( J )
+                  T = WORK( JP )
+                  IF( JP.NE.J ) THEN
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+                  CALL SAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
+   20          CONTINUE
+            END IF
+*
+*           Multiply by inv(U).
+*
+            CALL SLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+     $                   INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL SLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+     $                   INFO )
+*
+*           Multiply by inv(L').
+*
+            IF( LNOTI ) THEN
+               DO 30 J = N - 1, 1, -1
+                  LM = MIN( KL, N-J )
+                  WORK( J ) = WORK( J ) - SDOT( LM, AB( KD+1, J ), 1,
+     $                        WORK( J+1 ), 1 )
+                  JP = IPIV( J )
+                  IF( JP.NE.J ) THEN
+                     T = WORK( JP )
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+   30          CONTINUE
+            END IF
+         END IF
+*
+*        Divide X by 1/SCALE if doing so will not cause overflow.
+*
+         NORMIN = 'Y'
+         IF( SCALE.NE.ONE ) THEN
+            IX = ISAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 40
+            CALL SRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of SGBCON
+*
+      END
diff --git a/SRC/sgbequ.f b/SRC/sgbequ.f
new file mode 100644
index 00000000..4a415a45
--- /dev/null
+++ b/SRC/sgbequ.f
@@ -0,0 +1,239 @@
+      SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, 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, KL, KU, LDAB, M, N
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBEQU computes row and column scalings intended to equilibrate an
+*  M-by-N band matrix A and reduce its condition number.  R returns the
+*  row scale factors and C the column scale factors, chosen to try to
+*  make the largest element in each row and column of the matrix B with
+*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+*  number and BIGNUM = largest safe number.  Use of these scaling
+*  factors is not guaranteed to reduce the condition number of A but
+*  works well in practice.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  R       (output) REAL array, dimension (M)
+*          If INFO = 0, or INFO > M, R contains the row scale factors
+*          for A.
+*
+*  C       (output) REAL array, dimension (N)
+*          If INFO = 0, C contains the column scale factors for A.
+*
+*  ROWCND  (output) REAL
+*          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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, KD
+      REAL               BIGNUM, RCMAX, RCMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBEQU', -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 = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+*     Compute row scale factors.
+*
+      DO 10 I = 1, M
+         R( I ) = ZERO
+   10 CONTINUE
+*
+*     Find the maximum element in each row.
+*
+      KD = KU + 1
+      DO 30 J = 1, N
+         DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 40 I = 1, M
+         RCMAX = MAX( RCMAX, R( I ) )
+         RCMIN = MIN( RCMIN, R( I ) )
+   40 CONTINUE
+      AMAX = RCMAX
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 50 I = 1, M
+            IF( R( I ).EQ.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   50    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 60 I = 1, M
+            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+   60    CONTINUE
+*
+*        Compute ROWCND = min(R(I)) / max(R(I))
+*
+         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+*     Compute column scale factors
+*
+      DO 70 J = 1, N
+         C( J ) = ZERO
+   70 CONTINUE
+*
+*     Find the maximum element in each column,
+*     assuming the row scaling computed above.
+*
+      KD = KU + 1
+      DO 90 J = 1, N
+         DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 100 J = 1, N
+         RCMIN = MIN( RCMIN, C( J ) )
+         RCMAX = MAX( RCMAX, C( J ) )
+  100 CONTINUE
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 110 J = 1, N
+            IF( C( J ).EQ.ZERO ) THEN
+               INFO = M + J
+               RETURN
+            END IF
+  110    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 120 J = 1, N
+            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+  120    CONTINUE
+*
+*        Compute COLCND = min(C(J)) / max(C(J))
+*
+         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+      RETURN
+*
+*     End of SGBEQU
+*
+      END
diff --git a/SRC/sgbrfs.f b/SRC/sgbrfs.f
new file mode 100644
index 00000000..a8e5feba
--- /dev/null
+++ b/SRC/sgbrfs.f
@@ -0,0 +1,355 @@
+      SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is banded, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The original band matrix A, stored in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input) REAL array, dimension (LDAFB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by SGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from SGBTRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SGBTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANST
+      INTEGER            COUNT, I, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGBMV, SGBTRS, SLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -9
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( KL+KU+2, N+1 )
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( '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 SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,
+     $               ONE, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               KK = KU + 1 - K
+               XK = ABS( X( K, J ) )
+               DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               KK = KU + 1 - K
+               DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                   WORK( N+1 ), N, INFO )
+            CALL SAXPY( 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 SLACN2 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 SLACN2( 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 SGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  120          CONTINUE
+               CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of SGBRFS
+*
+      END
diff --git a/SRC/sgbsv.f b/SRC/sgbsv.f
new file mode 100644
index 00000000..f6b502bd
--- /dev/null
+++ b/SRC/sgbsv.f
@@ -0,0 +1,142 @@
+      SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBSV computes the solution to a real system of linear equations
+*  A * X = B, where A is a band matrix of order N with KL subdiagonals
+*  and KU superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  The LU decomposition with partial pivoting and row interchanges is
+*  used to factor A as A = L * U, where L is a product of permutation
+*  and unit lower triangular matrices with KL subdiagonals, and U is
+*  upper triangular with KL+KU superdiagonals.  The factored form of A
+*  is then used to solve the system of equations A * X = B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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) REAL 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).
+*
+*  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 the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           SGBTRF, SGBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of the band matrix A.
+*
+      CALL SGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
+     $                B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of SGBSV
+*
+      END
diff --git a/SRC/sgbsvx.f b/SRC/sgbsvx.f
new file mode 100644
index 00000000..461d2edc
--- /dev/null
+++ b/SRC/sgbsvx.f
@@ -0,0 +1,516 @@
+      SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
+     $                   LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, TRANS
+      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBSVX uses the LU factorization to compute the solution to a real
+*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+*  where A is a band matrix of order N with KL subdiagonals and KU
+*  superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed by this subroutine:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
+*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+*     or diag(C)*B (if TRANS = 'T' or 'C').
+*
+*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+*     matrix A (after equilibration if FACT = 'E') as
+*        A = L * U,
+*     where L is a product of permutation and unit lower triangular
+*     matrices with KL subdiagonals, and U is upper triangular with
+*     KL+KU superdiagonals.
+*
+*  3. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+*     that it solves the original system before equilibration.
+*
+*  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, AFB and IPIV contain the factored form of
+*                  A.  If EQUED is not 'N', the matrix A has been
+*                  equilibrated with scaling factors given by R and C.
+*                  AB, AFB, and IPIV are not modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
+*
+*          If FACT = 'F' and EQUED is not 'N', then A must have been
+*          equilibrated by the scaling factors in R and/or C.  AB is not
+*          modified if FACT = 'F' or 'N', or if FACT = 'E' and
+*          EQUED = 'N' on exit.
+*
+*          On exit, if EQUED .ne. 'N', A is scaled as follows:
+*          EQUED = 'R':  A := diag(R) * A
+*          EQUED = 'C':  A := A * diag(C)
+*          EQUED = 'B':  A := diag(R) * A * diag(C).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input or output) REAL array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains details of the LU factorization of the band matrix
+*          A, as computed by SGBTRF.  U is stored as an upper triangular
+*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
+*          and the multipliers used during the factorization are stored
+*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is
+*          the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns details of the LU factorization of A.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns details of the LU factorization of the equilibrated
+*          matrix A (see the description of AB for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.
+*
+*  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 = L*U
+*          as computed by SGBTRF; row i of the matrix was interchanged
+*          with row IPIV(i).
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the original matrix A.
+*
+*          If FACT = 'E', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the equilibrated matrix A.
+*
+*  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) REAL 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) REAL 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) REAL array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit,
+*          if EQUED = 'N', B is not modified;
+*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+*          diag(R)*B;
+*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+*          overwritten by diag(C)*B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL 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) REAL
+*          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) REAL 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) REAL 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) REAL array, dimension (3*N)
+*          On exit, WORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If WORK(1) is much less than 1, then the stability
+*          of the LU factorization of the (equilibrated) matrix A
+*          could be poor. This also means that the solution X, condition
+*          estimator RCOND, and forward error bound FERR could be
+*          unreliable. If factorization fails with 0<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.
+*  =====================================================================
+*  Moved setting of INFO = N+1 so INFO does not subsequently get
+*  overwritten.  Sven, 17 Mar 05. 
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+      CHARACTER          NORM
+      INTEGER            I, INFEQU, J, J1, J2
+      REAL               AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANGB, SLANTB
+      EXTERNAL           LSAME, SLAMCH, SLANGB, SLANTB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGBCON, SGBEQU, SGBRFS, SGBTRF, SGBTRS,
+     $                   SLACPY, SLAQGB, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         ROWEQU = .FALSE.
+         COLEQU = .FALSE.
+      ELSE
+         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -8
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -10
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -12
+      ELSE
+         IF( ROWEQU ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 10 J = 1, N
+               RCMIN = MIN( RCMIN, R( J ) )
+               RCMAX = MAX( RCMAX, R( J ) )
+   10       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -13
+            ELSE IF( N.GT.0 ) THEN
+               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               ROWCND = ONE
+            END IF
+         END IF
+         IF( COLEQU .AND. INFO.EQ.0 ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 20 J = 1, N
+               RCMIN = MIN( RCMIN, C( J ) )
+               RCMAX = MAX( RCMAX, C( J ) )
+   20       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -14
+            ELSE IF( N.GT.0 ) THEN
+               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               COLCND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -16
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -18
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL SGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL SLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                   AMAX, EQUED )
+            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( NOTRAN ) THEN
+         IF( ROWEQU ) THEN
+            DO 40 J = 1, NRHS
+               DO 30 I = 1, N
+                  B( I, J ) = R( I )*B( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( COLEQU ) THEN
+         DO 60 J = 1, NRHS
+            DO 50 I = 1, N
+               B( I, J ) = C( I )*B( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the LU factorization of the band matrix A.
+*
+         DO 70 J = 1, N
+            J1 = MAX( J-KU, 1 )
+            J2 = MIN( J+KL, N )
+            CALL SCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
+     $                  AFB( KL+KU+1-J+J1, J ), 1 )
+   70    CONTINUE
+*
+         CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 ) THEN
+*
+*           Compute the reciprocal pivot growth factor of the
+*           leading rank-deficient INFO columns of A.
+*
+            ANORM = ZERO
+            DO 90 J = 1, INFO
+               DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+                  ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
+   80          CONTINUE
+   90       CONTINUE
+            RPVGRW = SLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
+     $                       AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
+     $                       WORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = ANORM / RPVGRW
+            END IF
+            WORK( 1 ) = RPVGRW
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A and the
+*     reciprocal pivot growth factor RPVGRW.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
+      RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = SLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
+     $             WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( NOTRAN ) THEN
+         IF( COLEQU ) THEN
+            DO 110 J = 1, NRHS
+               DO 100 I = 1, N
+                  X( I, J ) = C( I )*X( I, J )
+  100          CONTINUE
+  110       CONTINUE
+            DO 120 J = 1, NRHS
+               FERR( J ) = FERR( J ) / COLCND
+  120       CONTINUE
+         END IF
+      ELSE IF( ROWEQU ) THEN
+         DO 140 J = 1, NRHS
+            DO 130 I = 1, N
+               X( I, J ) = R( I )*X( I, J )
+  130       CONTINUE
+  140    CONTINUE
+         DO 150 J = 1, NRHS
+            FERR( J ) = FERR( J ) / ROWCND
+  150    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of SGBSVX
+*
+      END
diff --git a/SRC/sgbtf2.f b/SRC/sgbtf2.f
new file mode 100644
index 00000000..041b19d0
--- /dev/null
+++ b/SRC/sgbtf2.f
@@ -0,0 +1,202 @@
+      SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBTF2 computes an LU factorization of a real m-by-n band matrix A
+*  using partial pivoting with row interchanges.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U, because of fill-in resulting from the row
+*  interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JP, JU, KM, KV
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      EXTERNAL           ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGER, SSCAL, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in.
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Gaussian elimination with partial pivoting
+*
+*     Set fill-in elements in columns KU+2 to KV to zero.
+*
+      DO 20 J = KU + 2, MIN( KV, N )
+         DO 10 I = KV - J + 2, KL
+            AB( I, J ) = ZERO
+   10    CONTINUE
+   20 CONTINUE
+*
+*     JU is the index of the last column affected by the current stage
+*     of the factorization.
+*
+      JU = 1
+*
+      DO 40 J = 1, MIN( M, N )
+*
+*        Set fill-in elements in column J+KV to zero.
+*
+         IF( J+KV.LE.N ) THEN
+            DO 30 I = 1, KL
+               AB( I, J+KV ) = ZERO
+   30       CONTINUE
+         END IF
+*
+*        Find pivot and test for singularity. KM is the number of
+*        subdiagonal elements in the current column.
+*
+         KM = MIN( KL, M-J )
+         JP = ISAMAX( KM+1, AB( KV+1, J ), 1 )
+         IPIV( J ) = JP + J - 1
+         IF( AB( KV+JP, J ).NE.ZERO ) THEN
+            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
+*
+*           Apply interchange to columns J to JU.
+*
+            IF( JP.NE.1 )
+     $         CALL SSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
+     $                     AB( KV+1, J ), LDAB-1 )
+*
+            IF( KM.GT.0 ) THEN
+*
+*              Compute multipliers.
+*
+               CALL SSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
+*
+*              Update trailing submatrix within the band.
+*
+               IF( JU.GT.J )
+     $            CALL SGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
+     $                       AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
+     $                       LDAB-1 )
+            END IF
+         ELSE
+*
+*           If pivot is zero, set INFO to the index of the pivot
+*           unless a zero pivot has already been found.
+*
+            IF( INFO.EQ.0 )
+     $         INFO = J
+         END IF
+   40 CONTINUE
+      RETURN
+*
+*     End of SGBTF2
+*
+      END
diff --git a/SRC/sgbtrf.f b/SRC/sgbtrf.f
new file mode 100644
index 00000000..b33ad4d0
--- /dev/null
+++ b/SRC/sgbtrf.f
@@ -0,0 +1,441 @@
+      SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBTRF computes an LU factorization of a real m-by-n band matrix A
+*  using partial pivoting with row interchanges.
+*
+*  This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
+     $                   JU, K2, KM, KV, NB, NW
+      REAL               TEMP
+*     ..
+*     .. Local Arrays ..
+      REAL               WORK13( LDWORK, NBMAX ),
+     $                   WORK31( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV, ISAMAX
+      EXTERNAL           ILAENV, ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGBTF2, SGEMM, SGER, SLASWP, SSCAL,
+     $                   SSWAP, STRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBTRF', -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, 'SGBTRF', ' ', M, N, KL, KU )
+*
+*     The block size must not exceed the limit set by the size of the
+*     local arrays WORK13 and WORK31.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
+*
+*        Use unblocked code
+*
+         CALL SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+*        Zero the superdiagonal elements of the work array WORK13
+*
+         DO 20 J = 1, NB
+            DO 10 I = 1, J - 1
+               WORK13( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+*
+*        Zero the subdiagonal elements of the work array WORK31
+*
+         DO 40 J = 1, NB
+            DO 30 I = J + 1, NB
+               WORK31( I, J ) = ZERO
+   30       CONTINUE
+   40    CONTINUE
+*
+*        Gaussian elimination with partial pivoting
+*
+*        Set fill-in elements in columns KU+2 to KV to zero
+*
+         DO 60 J = KU + 2, MIN( KV, N )
+            DO 50 I = KV - J + 2, KL
+               AB( I, J ) = ZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+*        JU is the index of the last column affected by the current
+*        stage of the factorization
+*
+         JU = 1
+*
+         DO 180 J = 1, MIN( M, N ), NB
+            JB = MIN( NB, MIN( M, N )-J+1 )
+*
+*           The active part of the matrix is partitioned
+*
+*              A11   A12   A13
+*              A21   A22   A23
+*              A31   A32   A33
+*
+*           Here A11, A21 and A31 denote the current block of JB columns
+*           which is about to be factorized. The number of rows in the
+*           partitioning are JB, I2, I3 respectively, and the numbers
+*           of columns are JB, J2, J3. The superdiagonal elements of A13
+*           and the subdiagonal elements of A31 lie outside the band.
+*
+            I2 = MIN( KL-JB, M-J-JB+1 )
+            I3 = MIN( JB, M-J-KL+1 )
+*
+*           J2 and J3 are computed after JU has been updated.
+*
+*           Factorize the current block of JB columns
+*
+            DO 80 JJ = J, J + JB - 1
+*
+*              Set fill-in elements in column JJ+KV to zero
+*
+               IF( JJ+KV.LE.N ) THEN
+                  DO 70 I = 1, KL
+                     AB( I, JJ+KV ) = ZERO
+   70             CONTINUE
+               END IF
+*
+*              Find pivot and test for singularity. KM is the number of
+*              subdiagonal elements in the current column.
+*
+               KM = MIN( KL, M-JJ )
+               JP = ISAMAX( KM+1, AB( KV+1, JJ ), 1 )
+               IPIV( JJ ) = JP + JJ - J
+               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
+                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
+                  IF( JP.NE.1 ) THEN
+*
+*                    Apply interchange to columns J to J+JB-1
+*
+                     IF( JP+JJ-1.LT.J+KL ) THEN
+*
+                        CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              AB( KV+JP+JJ-J, J ), LDAB-1 )
+                     ELSE
+*
+*                       The interchange affects columns J to JJ-1 of A31
+*                       which are stored in the work array WORK31
+*
+                        CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                        CALL SSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
+     $                              AB( KV+JP, JJ ), LDAB-1 )
+                     END IF
+                  END IF
+*
+*                 Compute multipliers
+*
+                  CALL SSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
+     $                        1 )
+*
+*                 Update trailing submatrix within the band and within
+*                 the current block. JM is the index of the last column
+*                 which needs to be updated.
+*
+                  JM = MIN( JU, J+JB-1 )
+                  IF( JM.GT.JJ )
+     $               CALL SGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
+     $                          AB( KV, JJ+1 ), LDAB-1,
+     $                          AB( KV+1, JJ+1 ), LDAB-1 )
+               ELSE
+*
+*                 If pivot is zero, set INFO to the index of the pivot
+*                 unless a zero pivot has already been found.
+*
+                  IF( INFO.EQ.0 )
+     $               INFO = JJ
+               END IF
+*
+*              Copy current column of A31 into the work array WORK31
+*
+               NW = MIN( JJ-J+1, I3 )
+               IF( NW.GT.0 )
+     $            CALL SCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
+     $                        WORK31( 1, JJ-J+1 ), 1 )
+   80       CONTINUE
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply the row interchanges to the other blocks.
+*
+               J2 = MIN( JU-J+1, KV ) - JB
+               J3 = MAX( 0, JU-J-KV+1 )
+*
+*              Use SLASWP to apply the row interchanges to A12, A22, and
+*              A32.
+*
+               CALL SLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
+     $                      IPIV( J ), 1 )
+*
+*              Adjust the pivot indices.
+*
+               DO 90 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+   90          CONTINUE
+*
+*              Apply the row interchanges to A13, A23, and A33
+*              columnwise.
+*
+               K2 = J - 1 + JB + J2
+               DO 110 I = 1, J3
+                  JJ = K2 + I
+                  DO 100 II = J + I - 1, J + JB - 1
+                     IP = IPIV( II )
+                     IF( IP.NE.II ) THEN
+                        TEMP = AB( KV+1+II-JJ, JJ )
+                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
+                        AB( KV+1+IP-JJ, JJ ) = TEMP
+                     END IF
+  100             CONTINUE
+  110          CONTINUE
+*
+*              Update the relevant part of the trailing submatrix
+*
+               IF( J2.GT.0 ) THEN
+*
+*                 Update A12
+*
+                  CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,
+     $                        AB( KV+1-JB, J+JB ), LDAB-1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A22
+*
+                     CALL SGEMM( 'No transpose', 'No transpose', I2, J2,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+1, J+JB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A32
+*
+                     CALL SGEMM( 'No transpose', 'No transpose', I3, J2,
+     $                           JB, -ONE, WORK31, LDWORK,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
+                  END IF
+               END IF
+*
+               IF( J3.GT.0 ) THEN
+*
+*                 Copy the lower triangle of A13 into the work array
+*                 WORK13
+*
+                  DO 130 JJ = 1, J3
+                     DO 120 II = JJ, JB
+                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
+  120                CONTINUE
+  130             CONTINUE
+*
+*                 Update A13 in the work array
+*
+                  CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,
+     $                        WORK13, LDWORK )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A23
+*
+                     CALL SGEMM( 'No transpose', 'No transpose', I2, J3,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
+     $                           LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A33
+*
+                     CALL SGEMM( 'No transpose', 'No transpose', I3, J3,
+     $                           JB, -ONE, WORK31, LDWORK, WORK13,
+     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
+                  END IF
+*
+*                 Copy the lower triangle of A13 back into place
+*
+                  DO 150 JJ = 1, J3
+                     DO 140 II = JJ, JB
+                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
+  140                CONTINUE
+  150             CONTINUE
+               END IF
+            ELSE
+*
+*              Adjust the pivot indices.
+*
+               DO 160 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+  160          CONTINUE
+            END IF
+*
+*           Partially undo the interchanges in the current block to
+*           restore the upper triangular form of A31 and copy the upper
+*           triangle of A31 back into place
+*
+            DO 170 JJ = J + JB - 1, J, -1
+               JP = IPIV( JJ ) - JJ + 1
+               IF( JP.NE.1 ) THEN
+*
+*                 Apply interchange to columns J to JJ-1
+*
+                  IF( JP+JJ-1.LT.J+KL ) THEN
+*
+*                    The interchange does not affect A31
+*
+                     CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )
+                  ELSE
+*
+*                    The interchange does affect A31
+*
+                     CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                  END IF
+               END IF
+*
+*              Copy the current column of A31 back into place
+*
+               NW = MIN( I3, JJ-J+1 )
+               IF( NW.GT.0 )
+     $            CALL SCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
+     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )
+  170       CONTINUE
+  180    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SGBTRF
+*
+      END
diff --git a/SRC/sgbtrs.f b/SRC/sgbtrs.f
new file mode 100644
index 00000000..e6ea0a8a
--- /dev/null
+++ b/SRC/sgbtrs.f
@@ -0,0 +1,186 @@
+      SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGBTRS solves a system of linear equations
+*     A * X = B  or  A' * X = B
+*  with a general band matrix A using the LU factorization computed
+*  by SGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by SGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= N, row i of the matrix was
+*          interchanged with row IPIV(i).
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LNOTI, NOTRAN
+      INTEGER            I, J, KD, L, LM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SGER, SSWAP, STBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      KD = KU + KL + 1
+      LNOTI = KL.GT.0
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve  A*X = B.
+*
+*        Solve L*X = B, overwriting B with X.
+*
+*        L is represented as a product of permutations and unit lower
+*        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
+*        where each transformation L(i) is a rank-one modification of
+*        the identity matrix.
+*
+         IF( LNOTI ) THEN
+            DO 10 J = 1, N - 1
+               LM = MIN( KL, N-J )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+               CALL SGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
+     $                    LDB, B( J+1, 1 ), LDB )
+   10       CONTINUE
+         END IF
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
+     $                  AB, LDAB, B( 1, I ), 1 )
+   20    CONTINUE
+*
+      ELSE
+*
+*        Solve A'*X = B.
+*
+         DO 30 I = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
+     $                  LDAB, B( 1, I ), 1 )
+   30    CONTINUE
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         IF( LNOTI ) THEN
+            DO 40 J = N - 1, 1, -1
+               LM = MIN( KL, N-J )
+               CALL SGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
+     $                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of SGBTRS
+*
+      END
diff --git a/SRC/sgebak.f b/SRC/sgebak.f
new file mode 100644
index 00000000..467e5a92
--- /dev/null
+++ b/SRC/sgebak.f
@@ -0,0 +1,188 @@
+      SUBROUTINE SGEBAK( 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 ..
+      REAL               V( LDV, * ), SCALE( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEBAK forms the right or left eigenvectors of a real general matrix
+*  by backward transformation on the computed eigenvectors of the
+*  balanced matrix output by SGEBAL.
+*
+*  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 SGEBAL.
+*
+*  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 SGEBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  SCALE   (input) REAL array, dimension (N)
+*          Details of the permutation and scaling factors, as returned
+*          by SGEBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) REAL array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by SHSEIN or STREVC.
+*          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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFTV, RIGHTV
+      INTEGER            I, II, K
+      REAL               S
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSWAP, 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( 'SGEBAK', -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 SSCAL( M, S, V( I, 1 ), LDV )
+   10       CONTINUE
+         END IF
+*
+         IF( LEFTV ) THEN
+            DO 20 I = ILO, IHI
+               S = ONE / SCALE( I )
+               CALL SSCAL( 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 SSWAP( 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 SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   50       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of SGEBAK
+*
+      END
diff --git a/SRC/sgebal.f b/SRC/sgebal.f
new file mode 100644
index 00000000..ba9fd173
--- /dev/null
+++ b/SRC/sgebal.f
@@ -0,0 +1,322 @@
+      SUBROUTINE SGEBAL( 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 ..
+      REAL               A( LDA, * ), SCALE( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEBAL 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) REAL 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) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied to
+*          A.  If P(j) is the index of the row and column interchanged
+*          with row and column j and D(j) is the scaling factor
+*          applied to row and column j, then
+*          SCALE(j) = P(j)    for j = 1,...,ILO-1
+*                   = D(j)    for j = ILO,...,IHI
+*                   = P(j)    for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  INFO    (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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               SCLFAC
+      PARAMETER          ( SCLFAC = 2.0E+0 )
+      REAL               FACTOR
+      PARAMETER          ( FACTOR = 0.95E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOCONV
+      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
+      REAL               C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+     $                   SFMIN2
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSWAP, 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( 'SGEBAL', -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 SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL SSWAP( 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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      SFMAX1 = ONE / SFMIN1
+      SFMIN2 = SFMIN1*SCLFAC
+      SFMAX2 = ONE / SFMIN2
+  140 CONTINUE
+      NOCONV = .FALSE.
+*
+      DO 200 I = K, L
+         C = ZERO
+         R = ZERO
+*
+         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 = ISAMAX( L, A( 1, I ), 1 )
+         CA = ABS( A( ICA, I ) )
+         IRA = ISAMAX( 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 SSCAL( N-K+1, G, A( I, K ), LDA )
+         CALL SSCAL( L, F, A( 1, I ), 1 )
+*
+  200 CONTINUE
+*
+      IF( NOCONV )
+     $   GO TO 140
+*
+  210 CONTINUE
+      ILO = K
+      IHI = L
+*
+      RETURN
+*
+*     End of SGEBAL
+*
+      END
diff --git a/SRC/sgebd2.f b/SRC/sgebd2.f
new file mode 100644
index 00000000..7c46c164
--- /dev/null
+++ b/SRC/sgebd2.f
@@ -0,0 +1,239 @@
+      SUBROUTINE SGEBD2( 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 ..
+      REAL               A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEBD2 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) REAL 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) REAL array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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) REAL array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q. See Further Details.
+*
+*  TAUP    (output) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix P. See Further Details.
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFG, 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( 'SGEBD2', -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 SLARFG( 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 SLARF( '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 SLARFG( 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 SLARF( '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 SLARFG( 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 SLARF( '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 SLARFG( 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 SLARF( '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 SGEBD2
+*
+      END
diff --git a/SRC/sgebrd.f b/SRC/sgebrd.f
new file mode 100644
index 00000000..a45aaba2
--- /dev/null
+++ b/SRC/sgebrd.f
@@ -0,0 +1,268 @@
+      SUBROUTINE SGEBRD( 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 ..
+      REAL               A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEBRD 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) REAL 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) REAL array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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) REAL array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q. See Further Details.
+*
+*  TAUP    (output) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix P. See Further Details.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
+     $                   NBMIN, NX
+      REAL               WS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEBD2, SGEMM, SLABRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) )
+      LWKOPT = ( M+N )*NB
+      WORK( 1 ) = REAL( 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( 'SGEBRD', -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, 'SGEBRD', ' ', 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, 'SGEBRD', ' ', 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 SLABRD( 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 SGEMM( '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 SGEMM( '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 SGEBD2( 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 SGEBRD
+*
+      END
diff --git a/SRC/sgecon.f b/SRC/sgecon.f
new file mode 100644
index 00000000..3cce1652
--- /dev/null
+++ b/SRC/sgecon.f
@@ -0,0 +1,185 @@
+      SUBROUTINE SGECON( 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGECON 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 SGETRF.
+*
+*  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) REAL array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by SGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) REAL
+*          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) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, SCALE, SL, SMLNUM, SU
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATRS, SRSCL, 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( 'SGECON', -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 = SLAMCH( '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 SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            CALL SLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
+     $                   LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+*
+*           Multiply by inv(U).
+*
+            CALL SLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL SLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+     $                   LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+*
+*           Multiply by inv(L').
+*
+            CALL SLATRS( '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 = ISAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL SRSCL( 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 SGECON
+*
+      END
diff --git a/SRC/sgeequ.f b/SRC/sgeequ.f
new file mode 100644
index 00000000..d875d1f4
--- /dev/null
+++ b/SRC/sgeequ.f
@@ -0,0 +1,225 @@
+      SUBROUTINE SGEEQU( 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
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEEQU 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) REAL 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) REAL array, dimension (M)
+*          If INFO = 0 or INFO > M, R contains the row scale factors
+*          for A.
+*
+*  C       (output) REAL array, dimension (N)
+*          If INFO = 0,  C contains the column scale factors for A.
+*
+*  ROWCND  (output) REAL
+*          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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               BIGNUM, RCMAX, RCMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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( 'SGEEQU', -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 = SLAMCH( '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 SGEEQU
+*
+      END
diff --git a/SRC/sgees.f b/SRC/sgees.f
new file mode 100644
index 00000000..e11d617a
--- /dev/null
+++ b/SRC/sgees.f
@@ -0,0 +1,434 @@
+      SUBROUTINE SGEES( 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( * )
+      REAL               A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+     $                   WR( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEES 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 REAL 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) REAL 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) REAL array, dimension (N)
+*  WI      (output) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. 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
+      REAL               ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD,
+     $                   SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. 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 SHSEQR, 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, 'SGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 3*N
+*
+            CALL SHSEQR( '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,
+     $                       'SORGHR', ' ', 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( 'SGEES ', -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 = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( '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 SGEBAL( '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 SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+*        Generate orthogonal matrix in VS
+*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL SORGHR( 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 SHSEQR( '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 SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+            CALL SLASCL( '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 STRSEN( '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 SGEBAK( '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 SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL SCOPY( 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 SLASCL( '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 SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+                     IF( N.GT.I+1 )
+     $                  CALL SSWAP( N-I-1, A( I, I+2 ), LDA,
+     $                              A( I+1, I+2 ), LDA )
+                     IF( WANTVS ) THEN
+                        CALL SSWAP( 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 SLASCL( '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 SGEES
+*
+      END
diff --git a/SRC/sgeesx.f b/SRC/sgeesx.f
new file mode 100644
index 00000000..a6f78995
--- /dev/null
+++ b/SRC/sgeesx.f
@@ -0,0 +1,527 @@
+      SUBROUTINE SGEESX( 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
+      REAL               RCONDE, RCONDV
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+     $                   WR( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEESX 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 REAL 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) REAL 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) REAL array, dimension (N)
+*  WI      (output) REAL 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) REAL 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) REAL
+*          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) REAL
+*          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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. 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, LWRK, LIWRK,
+     $                   MAXWRK, MINWRK
+      REAL               ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD,
+     $                   SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. 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 SHSEQR, 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 STRSEN 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, 'SGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 3*N
+*
+            CALL SHSEQR( '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,
+     $                       'SORGHR', ' ', 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( 'SGEESX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( '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 SGEBAL( '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 SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+*        Generate orthogonal matrix in VS
+*        (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL SORGHR( 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 SHSEQR( '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 SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+            CALL SLASCL( '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 STRSEN( 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
+*
+*           STRSEN 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 SGEBAK( '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 SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL SCOPY( N, A, LDA+1, WR, 1 )
+         IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
+            DUM( 1 ) = RCONDV
+            CALL SLASCL( '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 SLASCL( '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 SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+                     IF( N.GT.I+1 )
+     $                  CALL SSWAP( N-I-1, A( I, I+2 ), LDA,
+     $                              A( I+1, I+2 ), LDA )
+                     CALL SSWAP( 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 SLASCL( '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 ) = SDIM*(N-SDIM)
+      ELSE
+         IWORK( 1 ) = 1
+      END IF
+*
+      RETURN
+*
+*     End of SGEESX
+*
+      END
diff --git a/SRC/sgeev.f b/SRC/sgeev.f
new file mode 100644
index 00000000..7af086a8
--- /dev/null
+++ b/SRC/sgeev.f
@@ -0,0 +1,423 @@
+      SUBROUTINE SGEEV( 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 ..
+      REAL               A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WI( * ), WORK( * ), WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEEV 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) REAL 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) REAL array, dimension (N)
+*  WI      (output) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
+      CHARACTER          SIDE
+      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
+     $                   MAXWRK, MINWRK, NOUT
+      REAL               ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+     $                   SN
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            SELECT( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
+     $                   SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV, ISAMAX
+      REAL               SLAMCH, SLANGE, SLAPY2, SNRM2
+      EXTERNAL           LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
+     $                   SNRM2
+*     ..
+*     .. 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 SHSEQR, 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, 'SGEHRD', ' ', N, 1, N, 0 )
+            IF( WANTVL ) THEN
+               MINWRK = 4*N
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'SORGHR', ' ', N, 1, N, -1 ) )
+               CALL SHSEQR( '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,
+     $                       'SORGHR', ' ', N, 1, N, -1 ) )
+               CALL SHSEQR( '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 SHSEQR( '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( 'SGEEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix
+*     (Workspace: need N)
+*
+      IBAL = 1
+      CALL SGEBAL( '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 SGEHRD( 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 SLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+*        Generate orthogonal matrix in VL
+*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL SORGHR( 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 SHSEQR( '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 SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+*        Generate orthogonal matrix in VR
+*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL SORGHR( 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 SHSEQR( '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 SHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 0 from SHSEQR, 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 STREVC( 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 SGEBAK( '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 / SNRM2( N, VL( 1, I ), 1 )
+               CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
+     $               SNRM2( N, VL( 1, I+1 ), 1 ) )
+               CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+               CALL SSCAL( 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 = ISAMAX( N, WORK( IWRK ), 1 )
+               CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+               CALL SROT( 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 SGEBAK( '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 / SNRM2( N, VR( 1, I ), 1 )
+               CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
+     $               SNRM2( N, VR( 1, I+1 ), 1 ) )
+               CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+               CALL SSCAL( 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 = ISAMAX( N, WORK( IWRK ), 1 )
+               CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+               CALL SROT( 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 SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.GT.0 ) THEN
+            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+     $                   IERR )
+            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+     $                   IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of SGEEV
+*
+      END
diff --git a/SRC/sgeevx.f b/SRC/sgeevx.f
new file mode 100644
index 00000000..41487fe9
--- /dev/null
+++ b/SRC/sgeevx.f
@@ -0,0 +1,555 @@
+      SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
+     $                   VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
+     $                   RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
+      REAL               ABNRM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), RCONDE( * ), RCONDV( * ),
+     $                   SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WI( * ), WORK( * ), WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
+*  eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+*  Optionally also, it computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
+*  (RCONDE), and reciprocal condition numbers for the right
+*  eigenvectors (RCONDV).
+*
+*  The right eigenvector v(j) of A satisfies
+*                   A * v(j) = lambda(j) * v(j)
+*  where lambda(j) is its eigenvalue.
+*  The left eigenvector u(j) of A satisfies
+*                u(j)**H * A = lambda(j) * u(j)**H
+*  where u(j)**H denotes the conjugate transpose of u(j).
+*
+*  The computed eigenvectors are normalized to have Euclidean norm
+*  equal to 1 and largest component real.
+*
+*  Balancing a matrix means permuting the rows and columns to make it
+*  more nearly upper triangular, and applying a diagonal similarity
+*  transformation D * A * D**(-1), where D is a diagonal matrix, to
+*  make its rows and columns closer in norm and the condition numbers
+*  of its eigenvalues and eigenvectors smaller.  The computed
+*  reciprocal condition numbers correspond to the balanced matrix.
+*  Permuting rows and columns will not change the condition numbers
+*  (in exact arithmetic) but diagonal scaling will.  For further
+*  explanation of balancing, see section 4.10.2 of the LAPACK
+*  Users' Guide.
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Indicates how the input matrix should be diagonally scaled
+*          and/or permuted to improve the conditioning of its
+*          eigenvalues.
+*          = 'N': Do not diagonally scale or permute;
+*          = 'P': Perform permutations to make the matrix more nearly
+*                 upper triangular. Do not diagonally scale;
+*          = 'S': Diagonally scale the matrix, i.e. replace A by
+*                 D*A*D**(-1), where D is a diagonal matrix chosen
+*                 to make the rows and columns of A more equal in
+*                 norm. Do not permute;
+*          = 'B': Both diagonally scale and permute A.
+*
+*          Computed reciprocal condition numbers will be for the matrix
+*          after balancing and/or permuting. Permuting does not change
+*          condition numbers (in exact arithmetic), but balancing does.
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N': left eigenvectors of A are not computed;
+*          = 'V': left eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVL must = 'V'.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N': right eigenvectors of A are not computed;
+*          = 'V': right eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVR must = 'V'.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': None are computed;
+*          = 'E': Computed for eigenvalues only;
+*          = 'V': Computed for right eigenvectors only;
+*          = 'B': Computed for eigenvalues and right eigenvectors.
+*
+*          If SENSE = 'E' or 'B', both left and right eigenvectors
+*          must also be computed (JOBVL = 'V' and JOBVR = 'V').
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A has been overwritten.  If JOBVL = 'V' or
+*          JOBVR = 'V', A contains the real Schur form of the balanced
+*          version of the input matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  WR      (output) REAL array, dimension (N)
+*  WI      (output) REAL array, dimension (N)
+*          WR and WI contain the real and imaginary parts,
+*          respectively, of the computed eigenvalues.  Complex
+*          conjugate pairs of eigenvalues will appear consecutively
+*          with the eigenvalue having the positive imaginary part
+*          first.
+*
+*  VL      (output) REAL 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) REAL 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, and if
+*          JOBVR = 'V', LDVR >= N.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values determined when A was
+*          balanced.  The balanced A(i,j) = 0 if I > J and 
+*          J = 1,...,ILO-1 or I = IHI+1,...,N.
+*
+*  SCALE   (output) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          when balancing A.  If P(j) is the index of the row and column
+*          interchanged with row and column j, and D(j) is the scaling
+*          factor applied to row and column j, then
+*          SCALE(J) = P(J),    for J = 1,...,ILO-1
+*                   = D(J),    for J = ILO,...,IHI
+*                   = P(J)     for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) REAL
+*          The one-norm of the balanced matrix (the maximum
+*          of the sum of absolute values of elements of any column).
+*
+*  RCONDE  (output) REAL array, dimension (N)
+*          RCONDE(j) is the reciprocal condition number of the j-th
+*          eigenvalue.
+*
+*  RCONDV  (output) REAL array, dimension (N)
+*          RCONDV(j) is the reciprocal condition number of the j-th
+*          right eigenvector.
+*
+*  WORK    (workspace/output) REAL 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 SENSE = 'N' or 'E',
+*          LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
+*          LWORK >= 3*N.  If SENSE = 'V' or 'B', LWORK >= N*(N+6).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*N-2)
+*          If SENSE = 'N' or 'E', not referenced.
+*
+*  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 or condition numbers
+*                have been computed; elements 1:ILO-1 and i+1:N of WR
+*                and WI contain eigenvalues which have converged.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
+     $                   WNTSNN, WNTSNV
+      CHARACTER          JOB, SIDE
+      INTEGER            HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
+     $                   MINWRK, NOUT
+      REAL               ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+     $                   SN
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            SELECT( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
+     $                   SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
+     $                   STRSNA, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV, ISAMAX
+      REAL               SLAMCH, SLANGE, SLAPY2, SNRM2
+      EXTERNAL           LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
+     $                   SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVL = LSAME( JOBVL, 'V' )
+      WANTVR = LSAME( JOBVR, 'V' )
+      WNTSNN = LSAME( SENSE, 'N' )
+      WNTSNE = LSAME( SENSE, 'E' )
+      WNTSNV = LSAME( SENSE, 'V' )
+      WNTSNB = LSAME( SENSE, 'B' )
+      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) .OR.
+     $    LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
+     $         ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
+     $         WANTVR ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -11
+      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -13
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by SHSEQR, 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, 'SGEHRD', ' ', N, 1, N, 0 )
+*
+            IF( WANTVL ) THEN
+               CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+     $                WORK, -1, INFO )
+            ELSE IF( WANTVR ) THEN
+               CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+     $                WORK, -1, INFO )
+            ELSE
+               IF( WNTSNN ) THEN
+                  CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
+     $                LDVR, WORK, -1, INFO )
+               ELSE
+                  CALL SHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
+     $                LDVR, WORK, -1, INFO )
+               END IF
+            END IF
+            HSWORK = WORK( 1 )
+*
+            IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+               MINWRK = 2*N
+               IF( .NOT.WNTSNN )
+     $            MINWRK = MAX( MINWRK, N*N+6*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               IF( .NOT.WNTSNN )
+     $            MAXWRK = MAX( MAXWRK, N*N + 6*N )
+            ELSE
+               MINWRK = 3*N
+               IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+     $            MINWRK = MAX( MINWRK, N*N + 6*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'SORGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+     $            MAXWRK = MAX( MAXWRK, N*N + 6*N )
+               MAXWRK = MAX( MAXWRK, 3*N )
+            END IF
+            MAXWRK = MAX( MAXWRK, MINWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -21
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGEEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ICOND = 0
+      ANRM = SLANGE( '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 SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix and compute ABNRM
+*
+      CALL SGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
+      ABNRM = SLANGE( '1', N, N, A, LDA, DUM )
+      IF( SCALEA ) THEN
+         DUM( 1 ) = ABNRM
+         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+         ABNRM = DUM( 1 )
+      END IF
+*
+*     Reduce to upper Hessenberg form
+*     (Workspace: need 2*N, prefer N+N*NB)
+*
+      ITAU = 1
+      IWRK = ITAU + N
+      CALL SGEHRD( 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 SLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+*        Generate orthogonal matrix in VL
+*        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+         CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VL
+*        (Workspace: need 1, prefer HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL SHSEQR( '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 SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+*        Generate orthogonal matrix in VR
+*        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+         CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VR
+*        (Workspace: need 1, prefer HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+      ELSE
+*
+*        Compute eigenvalues only
+*        If condition numbers desired, compute Schur form
+*
+         IF( WNTSNN ) THEN
+            JOB = 'E'
+         ELSE
+            JOB = 'S'
+         END IF
+*
+*        (Workspace: need 1, prefer HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL SHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 0 from SHSEQR, then quit
+*
+      IF( INFO.GT.0 )
+     $   GO TO 50
+*
+      IF( WANTVL .OR. WANTVR ) THEN
+*
+*        Compute left and/or right eigenvectors
+*        (Workspace: need 3*N)
+*
+         CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                N, NOUT, WORK( IWRK ), IERR )
+      END IF
+*
+*     Compute condition numbers if desired
+*     (Workspace: need N*N+6*N unless SENSE = 'E')
+*
+      IF( .NOT.WNTSNN ) THEN
+         CALL STRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
+     $                ICOND )
+      END IF
+*
+      IF( WANTVL ) THEN
+*
+*        Undo balancing of left eigenvectors
+*
+         CALL SGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
+     $                IERR )
+*
+*        Normalize left eigenvectors and make largest component real
+*
+         DO 20 I = 1, N
+            IF( WI( I ).EQ.ZERO ) THEN
+               SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
+               CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
+     $               SNRM2( N, VL( 1, I+1 ), 1 ) )
+               CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+               CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
+               DO 10 K = 1, N
+                  WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
+   10          CONTINUE
+               K = ISAMAX( N, WORK, 1 )
+               CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+               CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+               VL( K, I+1 ) = ZERO
+            END IF
+   20    CONTINUE
+      END IF
+*
+      IF( WANTVR ) THEN
+*
+*        Undo balancing of right eigenvectors
+*
+         CALL SGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
+     $                IERR )
+*
+*        Normalize right eigenvectors and make largest component real
+*
+         DO 40 I = 1, N
+            IF( WI( I ).EQ.ZERO ) THEN
+               SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
+               CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
+     $               SNRM2( N, VR( 1, I+1 ), 1 ) )
+               CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+               CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
+               DO 30 K = 1, N
+                  WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
+   30          CONTINUE
+               K = ISAMAX( N, WORK, 1 )
+               CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+               CALL SROT( 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 SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.EQ.0 ) THEN
+            IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
+     $         CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
+     $                      IERR )
+         ELSE
+            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+     $                   IERR )
+            CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+     $                   IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of SGEEVX
+*
+      END
diff --git a/SRC/sgegs.f b/SRC/sgegs.f
new file mode 100644
index 00000000..a3a7d9f9
--- /dev/null
+++ b/SRC/sgegs.f
@@ -0,0 +1,438 @@
+      SUBROUTINE SGEGS( 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 ..
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+     $                   VSR( LDVSR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine SGGES.
+*
+*  SGEGS 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
+*  SGEGV should be used instead.  See SGEGV 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) REAL 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) REAL 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) REAL array, dimension (N)
+*          The real parts of each scalar alpha defining an eigenvalue
+*          of GNEP.
+*
+*  ALPHAI  (output) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 SGEQRF, SORMQR, and SORGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR
+*          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 SGGBAL
+*                =N+2: error return from SGEQRF
+*                =N+3: error return from SORMQR
+*                =N+4: error return from SORGQR
+*                =N+5: error return from SGGHRD
+*                =N+6: error return from SHGEQZ (other than failed
+*                                                iteration)
+*                =N+7: error return from SGGBAK (computing VSL)
+*                =N+8: error return from SGGBAK (computing VSR)
+*                =N+9: error return from SLASCL (various places)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. 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
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SAFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
+     $                   SLASCL, SLASET, SORGQR, SORMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANGE
+*     ..
+*     .. 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, 'SGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'SORGQR', ' ', 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( 'SGEGS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+      SAFMIN = SLAMCH( 'S' )
+      SMLNUM = N*SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( '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 = SLANGE( '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 SLASCL( '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 SGGBAL( '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 SGEQRF( 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 SORMQR( '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 SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VSL( ILO+1, ILO ), LDVSL )
+         CALL SORGQR( 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 SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      CALL SGGHRD( 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 SHGEQZ( '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 SGGBAK( '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 SGGBAK( '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 SLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL SLASCL( '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 SLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL SLASCL( '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 SGEGS
+*
+      END
diff --git a/SRC/sgegv.f b/SRC/sgegv.f
new file mode 100644
index 00000000..08c811c3
--- /dev/null
+++ b/SRC/sgegv.f
@@ -0,0 +1,665 @@
+      SUBROUTINE SGEGV( 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 ..
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine SGGEV.
+*
+*  SGEGV computes the eigenvalues and, optionally, the left and/or right
+*  eigenvectors of a real matrix pair (A,B).
+*  Given two square matrices A and B,
+*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
+*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such
+*  that
+*
+*     A*x = lambda*B*x.
+*
+*  An alternate form is to find the eigenvalues mu and corresponding
+*  eigenvectors y such that
+*
+*     mu*A*y = B*y.
+*
+*  These two forms are equivalent with mu = 1/lambda and x = y if
+*  neither lambda nor mu is zero.  In order to deal with the case that
+*  lambda or mu is zero or small, two values alpha and beta are returned
+*  for each eigenvalue, such that lambda = alpha/beta and
+*  mu = beta/alpha.
+*
+*  The vectors x and y in the above equations are right eigenvectors of
+*  the matrix pair (A,B).  Vectors u and v satisfying
+*
+*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B
+*
+*  are left eigenvectors of (A,B).
+*
+*  Note: this routine performs "full balancing" on A and B -- see
+*  "Further Details", below.
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N':  do not compute the left generalized eigenvectors;
+*          = 'V':  compute the left generalized eigenvectors (returned
+*                  in VL).
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N':  do not compute the right generalized eigenvectors;
+*          = 'V':  compute the right generalized eigenvectors (returned
+*                  in VR).
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VL, and VR.  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA, N)
+*          On entry, the matrix A.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit A
+*          contains the real Schur form of A from the generalized Schur
+*          factorization of the pair (A,B) after balancing.
+*          If no eigenvectors were computed, then only the diagonal
+*          blocks from the Schur form will be correct.  See SGGHRD and
+*          SHGEQZ for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) REAL array, dimension (LDB, N)
+*          On entry, the matrix B.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
+*          upper triangular matrix obtained from B in the generalized
+*          Schur factorization of the pair (A,B) after balancing.
+*          If no eigenvectors were computed, then only those elements of
+*          B corresponding to the diagonal blocks from the Schur form of
+*          A will be correct.  See SGGHRD and SHGEQZ for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHAR  (output) REAL array, dimension (N)
+*          The real parts of each scalar alpha defining an eigenvalue of
+*          GNEP.
+*
+*  ALPHAI  (output) REAL 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) REAL 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.
+*
+*  VL      (output) REAL array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored
+*          in the columns of VL, in the same order as their eigenvalues.
+*          If the j-th eigenvalue is real, then u(j) = VL(:,j).
+*          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).
+*
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvectors
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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) REAL array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right eigenvectors x(j) are stored
+*          in the columns of VR, in the same order as their eigenvalues.
+*          If the j-th eigenvalue is real, then x(j) = VR(:,j).
+*          If the j-th and (j+1)-st eigenvalues form a complex conjugate
+*          pair, then
+*            x(j) = VR(:,j) + i*VR(:,j+1)
+*          and
+*            x(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvalues
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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) REAL 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.
+*          To compute the optimal value of LWORK, call ILAENV to get
+*          blocksizes (for SGEQRF, SORMQR, and SORGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;
+*          The optimal LWORK is:
+*              2*N + MAX( 6*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.  No eigenvectors have been
+*                calculated, 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 SGGBAL
+*                =N+2: error return from SGEQRF
+*                =N+3: error return from SORMQR
+*                =N+4: error return from SORGQR
+*                =N+5: error return from SGGHRD
+*                =N+6: error return from SHGEQZ (other than failed
+*                                                iteration)
+*                =N+7: error return from STGEVC
+*                =N+8: error return from SGGBAK (computing VL)
+*                =N+9: error return from SGGBAK (computing VR)
+*                =N+10: error return from SLASCL (various calls)
+*
+*  Further Details
+*  ===============
+*
+*  Balancing
+*  ---------
+*
+*  This driver calls SGGBAL to both permute and scale rows and columns
+*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
+*  and PL*B*R will be upper triangular except for the diagonal blocks
+*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
+*  possible.  The diagonal scaling matrices DL and DR are chosen so
+*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
+*  one (except for the elements that start out zero.)
+*
+*  After the eigenvalues and eigenvectors of the balanced matrices
+*  have been computed, SGGBAK transforms the eigenvectors back to what
+*  they would have been (in perfect arithmetic) if they had not been
+*  balanced.
+*
+*  Contents of A and B on Exit
+*  -------- -- - --- - -- ----
+*
+*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
+*  both), then on exit the arrays A and B will contain the real Schur
+*  form[*] of the "balanced" versions of A and B.  If no eigenvectors
+*  are computed, then only the diagonal blocks will be correct.
+*
+*  [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations",
+*      by Golub & van Loan, pub. by Johns Hopkins U. Press.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILIMIT, ILV, ILVL, ILVR, LQUERY
+      CHARACTER          CHTEMP
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
+     $                   LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+      REAL               ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
+     $                   BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
+     $                   SALFAI, SALFAR, SBETA, SCALE, TEMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
+     $                   SLASCL, SLASET, SORGQR, SORMQR, STGEVC, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, MAX
+*     ..
+*     .. 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
+*
+      LWKMIN = MAX( 8*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( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -12
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -16
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 )
+         NB = MAX( NB1, NB2, NB3 )
+         LOPT = 2*N + MAX( 6*N, N*(NB+1) )
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGEGV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+      SAFMIN = SLAMCH( 'S' )
+      SAFMIN = SAFMIN + SAFMIN
+      SAFMAX = ONE / SAFMIN
+      ONEPLS = ONE + ( 4*EPS )
+*
+*     Scale A
+*
+      ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+      ANRM1 = ANRM
+      ANRM2 = ONE
+      IF( ANRM.LT.ONE ) THEN
+         IF( SAFMAX*ANRM.LT.ONE ) THEN
+            ANRM1 = SAFMIN
+            ANRM2 = SAFMAX*ANRM
+         END IF
+      END IF
+*
+      IF( ANRM.GT.ZERO ) THEN
+         CALL SLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Scale B
+*
+      BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+      BNRM1 = BNRM
+      BNRM2 = ONE
+      IF( BNRM.LT.ONE ) THEN
+         IF( SAFMAX*BNRM.LT.ONE ) THEN
+            BNRM1 = SAFMIN
+            BNRM2 = SAFMAX*BNRM
+         END IF
+      END IF
+*
+      IF( BNRM.GT.ZERO ) THEN
+         CALL SLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Permute the matrix to make it more nearly triangular
+*     Workspace layout:  (8*N words -- "work" requires 6*N words)
+*        left_permutation, right_permutation, work...
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWORK = IRIGHT + N
+      CALL SGGBAL( '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 120
+      END IF
+*
+*     Reduce B to triangular form, and initialize VL and/or VR
+*     Workspace layout:  ("work..." must have at least N words)
+*        left_permutation, right_permutation, tau, work...
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = IWORK
+      IWORK = ITAU + IROWS
+      CALL SGEQRF( 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 120
+      END IF
+*
+      CALL SORMQR( '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 120
+      END IF
+*
+      IF( ILVL ) THEN
+         CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+         CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VL( ILO+1, ILO ), LDVL )
+         CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                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 120
+         END IF
+      END IF
+*
+      IF( ILVR )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      IF( ILV ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IINFO )
+      ELSE
+         CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
+      END IF
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 5
+         GO TO 120
+      END IF
+*
+*     Perform QZ algorithm
+*     Workspace layout:  ("work..." must have at least 1 word)
+*        left_permutation, right_permutation, work...
+*
+      IWORK = ITAU
+      IF( ILV ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+      CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
+     $             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 120
+      END IF
+*
+      IF( ILV ) THEN
+*
+*        Compute Eigenvectors  (STGEVC requires 6*N words of workspace)
+*
+         IF( ILVL ) THEN
+            IF( ILVR ) THEN
+               CHTEMP = 'B'
+            ELSE
+               CHTEMP = 'L'
+            END IF
+         ELSE
+            CHTEMP = 'R'
+         END IF
+*
+         CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+     $                VR, LDVR, N, IN, WORK( IWORK ), IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 120
+         END IF
+*
+*        Undo balancing on VL and VR, rescale
+*
+         IF( ILVL ) THEN
+            CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                   WORK( IRIGHT ), N, VL, LDVL, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 8
+               GO TO 120
+            END IF
+            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.SAFMIN )
+     $            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 SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+     $                   WORK( IRIGHT ), N, VR, LDVR, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 9
+               GO TO 120
+            END IF
+            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.SAFMIN )
+     $            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 in alpha, beta
+*
+*     Note: this does not give the alpha and beta for the unscaled
+*     problem.
+*
+*     Un-scaling is limited to avoid underflow in alpha and beta
+*     if they are significant.
+*
+      DO 110 JC = 1, N
+         ABSAR = ABS( ALPHAR( JC ) )
+         ABSAI = ABS( ALPHAI( JC ) )
+         ABSB = ABS( BETA( JC ) )
+         SALFAR = ANRM*ALPHAR( JC )
+         SALFAI = ANRM*ALPHAI( JC )
+         SBETA = BNRM*BETA( JC )
+         ILIMIT = .FALSE.
+         SCALE = ONE
+*
+*        Check for significant underflow in ALPHAI
+*
+         IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
+     $              MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
+*
+         ELSE IF( SALFAI.EQ.ZERO ) THEN
+*
+*           If insignificant underflow in ALPHAI, then make the
+*           conjugate eigenvalue real.
+*
+            IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
+               ALPHAI( JC-1 ) = ZERO
+            ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
+               ALPHAI( JC+1 ) = ZERO
+            END IF
+         END IF
+*
+*        Check for significant underflow in ALPHAR
+*
+         IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
+     $       MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
+     $              MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
+         END IF
+*
+*        Check for significant underflow in BETA
+*
+         IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
+     $              MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
+         END IF
+*
+*        Check for possible overflow when limiting scaling
+*
+         IF( ILIMIT ) THEN
+            TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
+     $             ABS( SBETA ) )
+            IF( TEMP.GT.ONE )
+     $         SCALE = SCALE / TEMP
+            IF( SCALE.LT.ONE )
+     $         ILIMIT = .FALSE.
+         END IF
+*
+*        Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
+*
+         IF( ILIMIT ) THEN
+            SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
+            SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
+            SBETA = ( SCALE*BETA( JC ) )*BNRM
+         END IF
+         ALPHAR( JC ) = SALFAR
+         ALPHAI( JC ) = SALFAI
+         BETA( JC ) = SBETA
+  110 CONTINUE
+*
+  120 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SGEGV
+*
+      END
diff --git a/SRC/sgehd2.f b/SRC/sgehd2.f
new file mode 100644
index 00000000..95a154e9
--- /dev/null
+++ b/SRC/sgehd2.f
@@ -0,0 +1,149 @@
+      SUBROUTINE SGEHD2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEHD2 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 SGEBAL; otherwise they should be
+*          set to 1 and N respectively. See Further Details.
+*          1 <= ILO <= IHI <= max(1,N).
+*
+*  A       (input/output) REAL 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) REAL array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFG, 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( 'SGEHD2', -INFO )
+         RETURN
+      END IF
+*
+      DO 10 I = ILO, IHI - 1
+*
+*        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
+*
+         CALL SLARFG( 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 SLARF( '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 SLARF( '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 SGEHD2
+*
+      END
diff --git a/SRC/sgehrd.f b/SRC/sgehrd.f
new file mode 100644
index 00000000..c5fe911a
--- /dev/null
+++ b/SRC/sgehrd.f
@@ -0,0 +1,273 @@
+      SUBROUTINE SGEHRD( 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 ..
+      REAL              A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEHRD 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 SGEBAL; 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) REAL 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) REAL 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) REAL 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 SGEHRD
+*  subroutine incorporating improvements proposed by Quintana-Orti and
+*  Van de Geijn (2005). 
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+      REAL              ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, 
+     $                     ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NH, NX
+      REAL              EI
+*     ..
+*     .. Local Arrays ..
+      REAL              T( LDT, NBMAX )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SGEHD2, SGEMM, SLAHR2, SLARFB, STRMM,
+     $                   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, 'SGEHRD', ' ', 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( 'SGEHRD', -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, 'SGEHRD', ' ', 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, 'SGEHRD', ' ', 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, 'SGEHRD', ' ', 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 SLAHR2( 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 SGEMM( '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 STRMM( 'Right', 'Lower', 'Transpose',
+     $                  'Unit', I, IB-1,
+     $                  ONE, A( I+1, I ), LDA, WORK, LDWORK )
+            DO 30 J = 0, IB-2
+               CALL SAXPY( 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 SLARFB( '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 SGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
+      WORK( 1 ) = IWS
+*
+      RETURN
+*
+*     End of SGEHRD
+*
+      END
diff --git a/SRC/sgelq2.f b/SRC/sgelq2.f
new file mode 100644
index 00000000..ba7a7850
--- /dev/null
+++ b/SRC/sgelq2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE SGELQ2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGELQ2 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      REAL               AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFP, 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( 'SGELQ2', -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 SLARFP( 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 SLARF( '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 SGELQ2
+*
+      END
diff --git a/SRC/sgelqf.f b/SRC/sgelqf.f
new file mode 100644
index 00000000..c197524a
--- /dev/null
+++ b/SRC/sgelqf.f
@@ -0,0 +1,195 @@
+      SUBROUTINE SGELQF( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGELQF 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) REAL 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           SGELQ2, SLARFB, SLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'SGELQF', ' ', 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( 'SGELQF', -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, 'SGELQF', ' ', 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, 'SGELQF', ' ', 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 SGELQ2( 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 SLARFT( '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 SLARFB( '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 SGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of SGELQF
+*
+      END
diff --git a/SRC/sgels.f b/SRC/sgels.f
new file mode 100644
index 00000000..c5afc362
--- /dev/null
+++ b/SRC/sgels.f
@@ -0,0 +1,422 @@
+      SUBROUTINE SGELS( 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 ..
+      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGELS 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) REAL 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 SGEQRF;
+*            if M <  N, A is overwritten by details of its LQ
+*                       factorization as returned by SGELQF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, TPSD
+      INTEGER            BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
+      REAL               ANRM, BIGNUM, BNRM, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               RWORK( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGELQF, SGEQRF, SLABAD, SLASCL, SLASET, SORMLQ,
+     $                   SORMQR, STRTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. 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, 'SGEQRF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LN', M, NRHS, N,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N,
+     $              -1 ) )
+            END IF
+         ELSE
+            NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LN', N, NRHS, M,
+     $              -1 ) )
+            END IF
+         END IF
+*
+         WSIZE = MAX( 1, MN + MAX( MN, NRHS )*NB )
+         WORK( 1 ) = REAL( WSIZE )
+*
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGELS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         CALL SLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         GO TO 50
+      END IF
+*
+      BROW = M
+      IF( TPSD )
+     $   BROW = N
+      BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SGEQRF( 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 SORMQR( '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 STRTRS( '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 STRTRS( '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 SORMQR( '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 SGELQF( 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 STRTRS( '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 SORMLQ( '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 SORMLQ( '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 STRTRS( '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 SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+*
+   50 CONTINUE
+      WORK( 1 ) = REAL( WSIZE )
+*
+      RETURN
+*
+*     End of SGELS
+*
+      END
diff --git a/SRC/sgelsd.f b/SRC/sgelsd.f
new file mode 100644
index 00000000..fb27c506
--- /dev/null
+++ b/SRC/sgelsd.f
@@ -0,0 +1,542 @@
+      SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND,
+     $                   RANK, WORK, LWORK, IWORK, 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGELSD computes the minimum-norm solution to a real linear least
+*  squares problem:
+*      minimize 2-norm(| b - A*x |)
+*  using the singular value decomposition (SVD) of A. A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The problem is solved in three steps:
+*  (1) Reduce the coefficient matrix A to bidiagonal form with
+*      Householder transformations, reducing the original problem
+*      into a "bidiagonal least squares problem" (BLS)
+*  (2) Solve the BLS using a divide and conquer approach.
+*  (3) Apply back all the Householder tranformations to solve
+*      the original least squares problem.
+*
+*  The effective rank of A is determined by treating as zero those
+*  singular values which are less than RCOND times the largest singular
+*  value.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of 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) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) REAL 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) REAL 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) REAL
+*          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) REAL 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 must be at least 1.
+*          The exact minimum amount of workspace needed depends on M,
+*          N and NRHS. As long as LWORK is at least
+*              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
+*          if M is greater than or equal to N or
+*              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
+*          if M is less than N, the code will execute correctly.
+*          SMLSIZ is returned by ILAENV and is equal to the maximum
+*          size of the subproblems at the bottom of the computation
+*          tree (usually about 25), and
+*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the array WORK and the
+*          minimum size of the array IWORK, and returns these values as
+*          the first entries of the WORK and IWORK arrays, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
+*          where MINMN = MIN( M,N ).
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
+     $                   LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK,
+     $                   MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
+      REAL               ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEBRD, SGELQF, SGEQRF, SLABAD, SLACPY, SLALSD,
+     $                   SLASCL, SLASET, SORMBR, SORMLQ, SORMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           SLAMCH, SLANGE, ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, LOG, MAX, MIN, REAL
+*     ..
+*     .. 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
+         LIWORK = 1
+         IF( MINMN.GT.0 ) THEN
+            SMLSIZ = ILAENV( 9, 'SGELSD', ' ', 0, 0, 0, 0 )
+            MNTHR = ILAENV( 6, 'SGELSD', ' ', M, N, NRHS, -1 )
+            NLVL = MAX( INT( LOG( REAL( MINMN ) / REAL( SMLSIZ + 1 ) ) /
+     $                  LOG( TWO ) ) + 1, 0 )
+            LIWORK = 3*MINMN*NLVL + 11*MINMN
+            MM = M
+            IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+*              Path 1a - overdetermined, with many more rows than
+*                        columns.
+*
+               MM = N
+               MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'SGEQRF', ' ', M,
+     $                       N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'SORMQR', 'LT',
+     $                       M, NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined.
+*
+               MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
+     $                       'SGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'SORMBR',
+     $                       'QLT', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
+     $                       'SORMBR', 'PLN', N, NRHS, N, -1 ) )
+               WLALSD = 9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS +
+     $                  ( SMLSIZ + 1 )**2
+               MAXWRK = MAX( MAXWRK, 3*N + WLALSD )
+               MINWRK = MAX( 3*N + MM, 3*N + NRHS, 3*N + WLALSD )
+            END IF
+            IF( N.GT.M ) THEN
+               WLALSD = 9*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS +
+     $                  ( SMLSIZ + 1 )**2
+               IF( N.GE.MNTHR ) THEN
+*
+*                 Path 2a - underdetermined, with many more columns
+*                           than rows.
+*
+                  MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
+     $                                  -1 )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+     $                          'SGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+     $                          'SORMBR', 'QLT', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
+     $                          'SORMBR', 'PLN', M, NRHS, M, -1 ) )
+                  IF( NRHS.GT.1 ) THEN
+                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+                  ELSE
+                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
+                  END IF
+                  MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'SORMLQ',
+     $                          'LT', N, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + WLALSD )
+!     XXX: Ensure the Path 2a case below is triggered.  The workspace
+!     calculation should use queries for all routines eventually.
+                  MAXWRK = MAX( MAXWRK,
+     $                 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) )
+               ELSE
+*
+*                 Path 2 - remaining underdetermined cases.
+*
+                  MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'SGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'SORMBR',
+     $                          'QLT', M, NRHS, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'SORMBR',
+     $                          'PLN', N, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + WLALSD )
+               END IF
+               MINWRK = MAX( 3*M + NRHS, 3*M + M, 3*M + WLALSD )
+            END IF
+         END IF
+         MINWRK = MIN( MINWRK, MAXWRK )
+         WORK( 1 ) = MAXWRK
+         IWORK( 1 ) = LIWORK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGELSD', -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 = SLAMCH( 'P' )
+      SFMIN = SLAMCH( 'S' )
+      SMLNUM = SFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A if max entry outside range [SMLNUM,BIGNUM].
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM.
+*
+         CALL SLASCL( '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 SLASCL( '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 SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+         RANK = 0
+         GO TO 10
+      END IF
+*
+*     Scale B if max entry outside range [SMLNUM,BIGNUM].
+*
+      BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM.
+*
+         CALL SLASCL( '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 SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     If M < N make sure certain entries of B are zero.
+*
+      IF( M.LT.N )
+     $   CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+*
+*     Overdetermined case.
+*
+      IF( M.GE.N ) THEN
+*
+*        Path 1 - overdetermined or exactly determined.
+*
+         MM = M
+         IF( M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns.
+*
+            MM = N
+            ITAU = 1
+            NWORK = ITAU + N
+*
+*           Compute A=Q*R.
+*           (Workspace: need 2*N, prefer N+N*NB)
+*
+            CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                   LWORK-NWORK+1, INFO )
+*
+*           Multiply B by transpose(Q).
+*           (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+            CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*           Zero out below R.
+*
+            IF( N.GT.1 ) THEN
+               CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+            END IF
+         END IF
+*
+         IE = 1
+         ITAUQ = IE + N
+         ITAUP = ITAUQ + N
+         NWORK = ITAUP + N
+*
+*        Bidiagonalize R in A.
+*        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+         CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R.
+*        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+         CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL SLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of R.
+*
+         CALL SORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+     $         MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN
+*
+*        Path 2a - underdetermined, with many more columns than rows
+*        and sufficient workspace for an efficient algorithm.
+*
+         LDWORK = M
+         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+     $       M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA
+         ITAU = 1
+         NWORK = M + 1
+*
+*        Compute A=L*Q.
+*        (Workspace: need 2*M, prefer M+M*NB)
+*
+         CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+         IL = NWORK
+*
+*        Copy L to WORK(IL), zeroing out above its diagonal.
+*
+         CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         IE = IL + LDWORK*M
+         ITAUQ = IE + M
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+*
+*        Bidiagonalize L in WORK(IL).
+*        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+         CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L.
+*        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+         CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUQ ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL SLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of L.
+*
+         CALL SORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUP ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Zero out below first M rows of B.
+*
+         CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+         NWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B.
+*        (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+         CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases.
+*
+         IE = 1
+         ITAUQ = IE + M
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+*
+*        Bidiagonalize A.
+*        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+         CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors.
+*        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+         CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL SLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of A.
+*
+         CALL SORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      END IF
+*
+*     Undo scaling.
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   10 CONTINUE
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWORK
+      RETURN
+*
+*     End of SGELSD
+*
+      END
diff --git a/SRC/sgelss.f b/SRC/sgelss.f
new file mode 100644
index 00000000..33e5977c
--- /dev/null
+++ b/SRC/sgelss.f
@@ -0,0 +1,617 @@
+      SUBROUTINE SGELSS( 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGELSS 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) REAL 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) REAL 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) REAL 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) REAL
+*          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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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
+      REAL               ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
+*     ..
+*     .. Local Arrays ..
+      REAL               VDUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SBDSQR, SCOPY, SGEBRD, SGELQF, SGEMM, SGEMV,
+     $                   SGEQRF, SLABAD, SLACPY, SLASCL, SLASET, SORGBR,
+     $                   SORMBR, SORMLQ, SORMQR, SRSCL, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. 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, 'SGELSS', ' ', 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, 'SGEQRF', ' ', M,
+     $                       N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'SORMQR', 'LT',
+     $                       M, NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined
+*
+*              Compute workspace needed for SBDSQR
+*
+               BDSPAC = MAX( 1, 5*N )
+               MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
+     $                       'SGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'SORMBR',
+     $                       'QLT', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
+     $                       'SORGBR', '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 SBDSQR
+*
+               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, 'SGELQF', ' ', M, N, -1,
+     $                                  -1 )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+     $                          'SGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+     $                          'SORMBR', 'QLT', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M +
+     $                          ( M - 1 )*ILAENV( 1, 'SORGBR', '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, 'SORMLQ',
+     $                          'LT', N, NRHS, M, -1 ) )
+               ELSE
+*
+*                 Path 2 - underdetermined
+*
+                  MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'SGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'SORMBR',
+     $                          'QLT', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'SORGBR',
+     $                          '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( 'SGELSS', -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 = SLAMCH( 'P' )
+      SFMIN = SLAMCH( 'S' )
+      SMLNUM = SFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SGEQRF( 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 SORMQR( '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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL SLASET( '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 SGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
+     $                  WORK, LDB )
+            CALL SLACPY( '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 SGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
+     $                     LDB, ZERO, WORK, N )
+               CALL SLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
+   20       CONTINUE
+         ELSE
+            CALL SGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+            CALL SCOPY( 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 SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+         IL = IWORK
+*
+*        Copy L to WORK(IL), zeroing out above it
+*
+         CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL SLASET( '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 SGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
+     $                  B, LDB, ZERO, WORK( IWORK ), LDB )
+            CALL SLACPY( '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 SGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
+     $                     B( 1, I ), LDB, ZERO, WORK( IWORK ), M )
+               CALL SLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
+     $                      LDB )
+   40       CONTINUE
+         ELSE
+            CALL SGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
+     $                  1, ZERO, WORK( IWORK ), 1 )
+            CALL SCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
+         END IF
+*
+*        Zero out below first M rows of B
+*
+         CALL SLASET( '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 SORMLQ( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL SLASET( '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 SGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
+     $                  WORK, LDB )
+            CALL SLACPY( '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 SGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
+     $                     LDB, ZERO, WORK, N )
+               CALL SLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
+   60       CONTINUE
+         ELSE
+            CALL SGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+            CALL SCOPY( N, WORK, 1, B, 1 )
+         END IF
+      END IF
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of SGELSS
+*
+      END
diff --git a/SRC/sgelsx.f b/SRC/sgelsx.f
new file mode 100644
index 00000000..9125bdc0
--- /dev/null
+++ b/SRC/sgelsx.f
@@ -0,0 +1,349 @@
+      SUBROUTINE SGELSX( 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine SGELSY.
+*
+*  SGELSX 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) REAL 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) REAL 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) REAL
+*          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) REAL 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 )
+      REAL               ZERO, ONE, DONE, NTDONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, DONE = ZERO,
+     $                   NTDONE = ONE )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
+      REAL               ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+     $                   SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQPF, SLABAD, SLAIC1, SLASCL, SLASET, SLATZM,
+     $                   SORM2R, STRSM, STZRQF, 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( 'SGELSX', -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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max elements outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         RANK = 0
+         GO TO 100
+      END IF
+*
+      BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SGEQPF( 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 SLASET( '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 SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL SLAIC1( 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 STZRQF( 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 SORM2R( '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 STRSM( '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 SLATZM( '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 SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of SGELSX
+*
+      END
diff --git a/SRC/sgelsy.f b/SRC/sgelsy.f
new file mode 100644
index 00000000..a7d3d8a7
--- /dev/null
+++ b/SRC/sgelsy.f
@@ -0,0 +1,391 @@
+      SUBROUTINE SGELSY( 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGELSY 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) REAL 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) REAL 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) REAL
+*          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) REAL 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 SGEQP3, STZRZF, STZRQF, SORMQR,
+*          and SORMRZ.
+*
+*          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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
+     $                   LWKOPT, MN, NB, NB1, NB2, NB3, NB4
+      REAL               ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+     $                   SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEQP3, SLABAD, SLAIC1, SLASCL, SLASET,
+     $                   SORMQR, SORMRZ, STRSM, STZRZF, 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, 'SGEQRF', ' ', M, N, -1, -1 )
+            NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+            NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, NRHS, -1 )
+            NB4 = ILAENV( 1, 'SORMRQ', ' ', 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( 'SGELSY', -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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+      BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL SLASCL( '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 SLASCL( '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 SGEQP3( 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 SLASET( '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 SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL SLAIC1( 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 STZRZF( 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 SORMQR( '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 STRSM( '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 SORMRZ( '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 SCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+   60 CONTINUE
+*
+*     workspace: N.
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SGELSY
+*
+      END
diff --git a/SRC/sgeql2.f b/SRC/sgeql2.f
new file mode 100644
index 00000000..187980de
--- /dev/null
+++ b/SRC/sgeql2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE SGEQL2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEQL2 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      REAL               AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFP, 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( 'SGEQL2', -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 SLARFP( 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 SLARF( '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 SGEQL2
+*
+      END
diff --git a/SRC/sgeqlf.f b/SRC/sgeqlf.f
new file mode 100644
index 00000000..347fa911
--- /dev/null
+++ b/SRC/sgeqlf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE SGEQLF( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEQLF 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) REAL 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           SGEQL2, SLARFB, SLARFT, 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, 'SGEQLF', ' ', 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( 'SGEQLF', -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, 'SGEQLF', ' ', 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, 'SGEQLF', ' ', 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 SGEQL2( 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 SLARFT( '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 SLARFB( '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 SGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of SGEQLF
+*
+      END
diff --git a/SRC/sgeqp3.f b/SRC/sgeqp3.f
new file mode 100644
index 00000000..0c0d9b87
--- /dev/null
+++ b/SRC/sgeqp3.f
@@ -0,0 +1,284 @@
+      SUBROUTINE SGEQP3( 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( * )
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEQP3 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) REAL 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           SGEQRF, SLAQP2, SLAQPS, SORMQR, SSWAP, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SNRM2
+      EXTERNAL           ILAENV, SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      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, 'SGEQRF', ' ', 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( 'SGEQP3', -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 SSWAP( 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 SGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
+         CALL SGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
+         IWS = MAX( IWS, INT( WORK( 1 ) ) )
+         IF( NA.LT.N ) THEN
+*CC         CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
+*CC  $                   TAU, A( 1, NA+1 ), LDA, WORK, INFO )
+            CALL SORMQR( '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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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 ) = SNRM2( 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 SLAQPS( 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 SLAQP2( 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 SGEQP3
+*
+      END
diff --git a/SRC/sgeqpf.f b/SRC/sgeqpf.f
new file mode 100644
index 00000000..f0c9afa8
--- /dev/null
+++ b/SRC/sgeqpf.f
@@ -0,0 +1,231 @@
+      SUBROUTINE SGEQPF( 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( * )
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine SGEQP3.
+*
+*  SGEQPF 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MA, MN, PVT
+      REAL               AII, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQR2, SLARF, SLARFP, SORM2R, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SNRM2
+      EXTERNAL           ISAMAX, SLAMCH, SNRM2
+*     ..
+*     .. 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( 'SGEQPF', -INFO )
+         RETURN
+      END IF
+*
+      MN = MIN( M, N )
+      TOL3Z = SQRT(SLAMCH('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 SSWAP( 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 SGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+         IF( MA.LT.N ) THEN
+            CALL SORM2R( '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 ) = SNRM2( 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 ) + ISAMAX( N-I+1, WORK( I ), 1 )
+*
+            IF( PVT.NE.I ) THEN
+               CALL SSWAP( 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 SLARFP( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
+            ELSE
+               CALL SLARFP( 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 SLARF( '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 ) = SNRM2( 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 SGEQPF
+*
+      END
diff --git a/SRC/sgeqr2.f b/SRC/sgeqr2.f
new file mode 100644
index 00000000..6c1ad935
--- /dev/null
+++ b/SRC/sgeqr2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE SGEQR2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEQR2 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      REAL               AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFP, 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( 'SGEQR2', -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 SLARFP( 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 SLARF( '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 SGEQR2
+*
+      END
diff --git a/SRC/sgeqrf.f b/SRC/sgeqrf.f
new file mode 100644
index 00000000..ae527007
--- /dev/null
+++ b/SRC/sgeqrf.f
@@ -0,0 +1,196 @@
+      SUBROUTINE SGEQRF( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGEQRF 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) REAL 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           SGEQR2, SLARFB, SLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'SGEQRF', ' ', 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( 'SGEQRF', -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, 'SGEQRF', ' ', 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, 'SGEQRF', ' ', 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 SGEQR2( 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 SLARFT( '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 SLARFB( '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 SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of SGEQRF
+*
+      END
diff --git a/SRC/sgerfs.f b/SRC/sgerfs.f
new file mode 100644
index 00000000..29014df4
--- /dev/null
+++ b/SRC/sgerfs.f
@@ -0,0 +1,336 @@
+      SUBROUTINE SGERFS( 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGERFS 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) REAL 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) REAL array, dimension (LDAF,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by SGETRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from SGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SGETRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANST
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SGETRS, SLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. 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( 'SGERFS', -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 = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( '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 SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SGEMV( 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 SGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                   INFO )
+            CALL SAXPY( 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 SLACN2 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 SLACN2( 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 SGETRS( 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 SGETRS( 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 SGERFS
+*
+      END
diff --git a/SRC/sgerq2.f b/SRC/sgerq2.f
new file mode 100644
index 00000000..e07936a1
--- /dev/null
+++ b/SRC/sgerq2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE SGERQ2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGERQ2 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      REAL               AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFP, 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( 'SGERQ2', -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 SLARFP( 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 SLARF( '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 SGERQ2
+*
+      END
diff --git a/SRC/sgerqf.f b/SRC/sgerqf.f
new file mode 100644
index 00000000..fb9b7a2d
--- /dev/null
+++ b/SRC/sgerqf.f
@@ -0,0 +1,216 @@
+      SUBROUTINE SGERQF( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGERQF 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) REAL 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           SGERQ2, SLARFB, SLARFT, 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
+      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         K = MIN( M, N )
+         IF( K.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+            LWKOPT = M*NB
+            WORK( 1 ) = LWKOPT
+         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( 'SGERQF', -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, 'SGERQF', ' ', 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, 'SGERQF', ' ', 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 SGERQ2( 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 SLARFT( '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 SLARFB( '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 SGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of SGERQF
+*
+      END
diff --git a/SRC/sgesc2.f b/SRC/sgesc2.f
new file mode 100644
index 00000000..de62e77d
--- /dev/null
+++ b/SRC/sgesc2.f
@@ -0,0 +1,132 @@
+      SUBROUTINE SGESC2( 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
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      REAL               A( LDA, * ), RHS( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGESC2 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 SGETC2.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  A       (input) REAL array, dimension (LDA,N)
+*          On entry, the  LU part of the factorization of the n-by-n
+*          matrix A computed by SGETC2:  A = P * L * U * Q
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1, N).
+*
+*  RHS     (input/output) REAL 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) REAL
+*           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 ..
+      REAL               ONE, TWO
+      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               BIGNUM, EPS, SMLNUM, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLABAD, SLASWP, SSCAL
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           ISAMAX, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*      Set constant to control owerflow
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+*     Apply permutations IPIV to RHS
+*
+      CALL SLASWP( 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 = ISAMAX( N, RHS, 1 )
+      IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
+         TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
+         CALL SSCAL( 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 SLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
+      RETURN
+*
+*     End of SGESC2
+*
+      END
diff --git a/SRC/sgesdd.f b/SRC/sgesdd.f
new file mode 100644
index 00000000..de3683d8
--- /dev/null
+++ b/SRC/sgesdd.f
@@ -0,0 +1,1339 @@
+      SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
+     $                   LWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ
+      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), S( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGESDD computes the singular value decomposition (SVD) of a real
+*  M-by-N matrix A, optionally computing the left and right singular
+*  vectors.  If singular vectors are desired, it uses a
+*  divide-and-conquer algorithm.
+*
+*  The SVD is written
+*
+*       A = U * SIGMA * transpose(V)
+*
+*  where SIGMA is an M-by-N matrix which is zero except for its
+*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
+*  are the singular values of A; they are real and non-negative, and
+*  are returned in descending order.  The first min(m,n) columns of
+*  U and V are the left and right singular vectors of A.
+*
+*  Note that the routine returns VT = V**T, not V.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix U:
+*          = 'A':  all M columns of U and all N rows of V**T are
+*                  returned in the arrays U and VT;
+*          = 'S':  the first min(M,N) columns of U and the first
+*                  min(M,N) rows of V**T are returned in the arrays U
+*                  and VT;
+*          = 'O':  If M >= N, the first N columns of U are overwritten
+*                  on the array A and all rows of V**T are returned in
+*                  the array VT;
+*                  otherwise, all columns of U are returned in the
+*                  array U and the first M rows of V**T are overwritten
+*                  in the array A;
+*          = 'N':  no columns of U or rows of V**T are computed.
+*
+*  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) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*          if JOBZ = 'O',  A is overwritten with the first N columns
+*                          of U (the left singular vectors, stored
+*                          columnwise) if M >= N;
+*                          A is overwritten with the first M rows
+*                          of V**T (the right singular vectors, stored
+*                          rowwise) otherwise.
+*          if JOBZ .ne. 'O', the contents of A are destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  S       (output) REAL array, dimension (min(M,N))
+*          The singular values of A, sorted so that S(i) >= S(i+1).
+*
+*  U       (output) REAL array, dimension (LDU,UCOL)
+*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
+*          UCOL = min(M,N) if JOBZ = 'S'.
+*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
+*          orthogonal matrix U;
+*          if JOBZ = 'S', U contains the first min(M,N) columns of U
+*          (the left singular vectors, stored columnwise);
+*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1; if
+*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
+*
+*  VT      (output) REAL array, dimension (LDVT,N)
+*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
+*          N-by-N orthogonal matrix V**T;
+*          if JOBZ = 'S', VT contains the first min(M,N) rows of
+*          V**T (the right singular vectors, stored rowwise);
+*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1; if
+*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
+*          if JOBZ = 'S', LDVT >= min(M,N).
+*
+*  WORK    (workspace/output) REAL 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 JOBZ = 'N',
+*            LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
+*          If JOBZ = 'O',
+*            LWORK >= 3*min(M,N)*min(M,N) + 
+*                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
+*          If JOBZ = 'S' or 'A'
+*            LWORK >= 3*min(M,N)*min(M,N) +
+*                     max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
+*          For good performance, LWORK should generally be larger.
+*          If LWORK = -1 but other input arguments are legal, WORK(1)
+*          returns the optimal LWORK.
+*
+*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  SBDSDC did not converge, updating process failed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
+      INTEGER            BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
+     $                   IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
+     $                   LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
+     $                   MNTHR, NWORK, WRKBL
+      REAL               ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SBDSDC, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
+     $                   SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      WNTQA = LSAME( JOBZ, 'A' )
+      WNTQS = LSAME( JOBZ, 'S' )
+      WNTQAS = WNTQA .OR. WNTQS
+      WNTQO = LSAME( JOBZ, 'O' )
+      WNTQN = LSAME( JOBZ, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
+     $         ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
+         INFO = -8
+      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
+     $         ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
+     $         ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
+         INFO = -10
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace 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 SBDSDC
+*
+            MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
+            IF( WNTQN ) THEN
+               BDSPAC = 7*N
+            ELSE
+               BDSPAC = 3*N*N + 4*N
+            END IF
+            IF( M.GE.MNTHR ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1 (M much larger than N, JOBZ='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1,
+     $                    -1 )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+N )
+                  MINWRK = BDSPAC + N
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2 (M much larger than N, JOBZ='O')
+*
+                  WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + 2*N*N
+                  MINWRK = BDSPAC + 2*N*N + 3*N
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3 (M much larger than N, JOBZ='S')
+*
+                  WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + N*N
+                  MINWRK = BDSPAC + N*N + 3*N
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4 (M much larger than N, JOBZ='A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + N*N
+                  MINWRK = BDSPAC + N*N + 3*N
+               END IF
+            ELSE
+*
+*              Path 5 (M at least N, but not much larger)
+*
+               WRKBL = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
+     $                 -1 )
+               IF( WNTQN ) THEN
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+                  MINWRK = 3*N + MAX( M, BDSPAC )
+               ELSE IF( WNTQO ) THEN
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
+                  MAXWRK = WRKBL + M*N
+                  MINWRK = 3*N + MAX( M, N*N+BDSPAC )
+               ELSE IF( WNTQS ) THEN
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+                  MINWRK = 3*N + MAX( M, BDSPAC )
+               ELSE IF( WNTQA ) THEN
+                  WRKBL = MAX( WRKBL, 3*N+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
+                  MINWRK = 3*N + MAX( M, BDSPAC )
+               END IF
+            END IF
+         ELSE IF ( MINMN.GT.0 ) THEN
+*
+*           Compute space needed for SBDSDC
+*
+            MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
+            IF( WNTQN ) THEN
+               BDSPAC = 7*M
+            ELSE
+               BDSPAC = 3*M*M + 4*M
+            END IF
+            IF( N.GE.MNTHR ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1t (N much larger than M, JOBZ='N')
+*
+                  WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
+     $                    -1 )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+M )
+                  MINWRK = BDSPAC + M
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2t (N much larger than M, JOBZ='O')
+*
+                  WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + 2*M*M
+                  MINWRK = BDSPAC + 2*M*M + 3*M
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3t (N much larger than M, JOBZ='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + M*M
+                  MINWRK = BDSPAC + M*M + 3*M
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4t (N much larger than M, JOBZ='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + M*M
+                  MINWRK = BDSPAC + M*M + 3*M
+               END IF
+            ELSE
+*
+*              Path 5t (N greater than M, but not much larger)
+*
+               WRKBL = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
+     $                 -1 )
+               IF( WNTQN ) THEN
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+                  MINWRK = 3*M + MAX( N, BDSPAC )
+               ELSE IF( WNTQO ) THEN
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
+                  MAXWRK = WRKBL + M*N
+                  MINWRK = 3*M + MAX( N, M*M+BDSPAC )
+               ELSE IF( WNTQS ) THEN
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+                  MINWRK = 3*M + MAX( N, BDSPAC )
+               ELSE IF( WNTQA ) THEN
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) )
+                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+                  MINWRK = 3*M + MAX( N, BDSPAC )
+               END IF
+            END IF
+         END IF
+         MAXWRK = MAX( MAXWRK, MINWRK )
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGESDD', -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 = SLAMCH( 'P' )
+      SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        A has at least as many rows as columns. If A has sufficiently
+*        more rows than columns, first reduce using the QR
+*        decomposition (if sufficient workspace available)
+*
+         IF( M.GE.MNTHR ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1 (M much larger than N, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need 2*N, prefer N+N*NB)
+*
+               CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+               IE = 1
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+               CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NWORK = IE + N
+*
+*              Perform bidiagonal SVD, computing singular values only
+*              (Workspace: need N+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2 (M much larger than N, JOBZ = 'O')
+*              N left singular vectors to be overwritten on A and
+*              N right singular vectors to be computed in VT
+*
+               IR = 1
+*
+*              WORK(IR) is LDWRKR by N
+*
+               IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
+                  LDWRKR = LDA
+               ELSE
+                  LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
+               END IF
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy R to WORK(IR), zeroing out below it
+*
+               CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+               CALL SLASET( '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 SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in VT, copying result to WORK(IR)
+*              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+               CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              WORK(IU) is N by N
+*
+               IU = NWORK
+               NWORK = IU + N*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in WORK(IU) and computing right
+*              singular vectors of bidiagonal matrix in VT
+*              (Workspace: need N+N*N+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+     $                      VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite WORK(IU) by left singular vectors of R
+*              and VT by right singular vectors of R
+*              (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IU), storing result in WORK(IR) and copying to A
+*              (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+               DO 10 I = 1, M, LDWRKR
+                  CHUNK = MIN( M-I+1, LDWRKR )
+                  CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                        LDA, WORK( IU ), N, ZERO, WORK( IR ),
+     $                        LDWRKR )
+                  CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+     $                         A( I, 1 ), LDA )
+   10          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Path 3 (M much larger than N, JOBZ='S')
+*              N left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IR = 1
+*
+*              WORK(IR) is N by N
+*
+               LDWRKR = N
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy R to WORK(IR), zeroing out below it
+*
+               CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+               CALL SLASET( '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 SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in WORK(IR)
+*              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+               CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagoal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need N+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of R and VT
+*              by right singular vectors of R
+*              (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IR), storing result in U
+*              (Workspace: need N*N)
+*
+               CALL SLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
+               CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
+     $                     LDWRKR, ZERO, U, LDU )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 4 (M much larger than N, JOBZ='A')
+*              M left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IU = 1
+*
+*              WORK(IU) is N by N
+*
+               LDWRKU = N
+               ITAU = IU + LDWRKU*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R, copying result to U
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*              Generate Q in U
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+               CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce R in A, zeroing out other entries
+*
+               CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+               IE = ITAU
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+               CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in WORK(IU) and computing right
+*              singular vectors of bidiagonal matrix in VT
+*              (Workspace: need N+N*N+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+     $                      VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite WORK(IU) by left singular vectors of R and VT
+*              by right singular vectors of R
+*              (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
+     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in U by left singular vectors of R in
+*              WORK(IU), storing result in A
+*              (Workspace: need N*N)
+*
+               CALL SGEMM( '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 SLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+            END IF
+*
+         ELSE
+*
+*           M .LT. MNTHR
+*
+*           Path 5 (M at least N, but not much larger)
+*           Reduce to bidiagonal form without QR decomposition
+*
+            IE = 1
+            ITAUQ = IE + N
+            ITAUP = ITAUQ + N
+            NWORK = ITAUP + N
+*
+*           Bidiagonalize A
+*           (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+            CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Perform bidiagonal SVD, only computing singular values
+*              (Workspace: need N+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IU = NWORK
+               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+*                 WORK( IU ) is M by N
+*
+                  LDWRKU = M
+                  NWORK = IU + LDWRKU*N
+                  CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
+     $                         LDWRKU )
+               ELSE
+*
+*                 WORK( IU ) is N by N
+*
+                  LDWRKU = N
+                  NWORK = IU + LDWRKU*N
+*
+*                 WORK(IR) is LDWRKR by N
+*
+                  IR = NWORK
+                  LDWRKR = ( LWORK-N*N-3*N ) / N
+               END IF
+               NWORK = IU + LDWRKU*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in WORK(IU) and computing right
+*              singular vectors of bidiagonal matrix in VT
+*              (Workspace: need N+N*N+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
+     $                      LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
+     $                      IWORK, INFO )
+*
+*              Overwrite VT by right singular vectors of A
+*              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+               CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+*                 Overwrite WORK(IU) by left singular vectors of A
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                         WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Copy left singular vectors of A from WORK(IU) to A
+*
+                  CALL SLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
+               ELSE
+*
+*                 Generate Q in A
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by left singular vectors of
+*                 bidiagonal matrix in WORK(IU), storing result in
+*                 WORK(IR) and copying to A
+*                 (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+                  DO 20 I = 1, M, LDWRKR
+                     CHUNK = MIN( M-I+1, LDWRKR )
+                     CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                           LDA, WORK( IU ), LDWRKU, ZERO,
+     $                           WORK( IR ), LDWRKR )
+                     CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+     $                            A( I, 1 ), LDA )
+   20             CONTINUE
+               END IF
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need N+BDSPAC)
+*
+               CALL SLASET( 'F', M, N, ZERO, ZERO, U, LDU )
+               CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE IF( WNTQA ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need N+BDSPAC)
+*
+               CALL SLASET( 'F', M, M, ZERO, ZERO, U, LDU )
+               CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Set the right corner of U to identity matrix
+*
+               IF( M.GT.N ) THEN
+                  CALL SLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
+     $                         LDU )
+               END IF
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      ELSE
+*
+*        A has more columns than rows. If A has sufficiently more
+*        columns than rows, first reduce using the LQ decomposition (if
+*        sufficient workspace available)
+*
+         IF( N.GE.MNTHR ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1t (N much larger than M, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need 2*M, prefer M+M*NB)
+*
+               CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+               IE = 1
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+               CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NWORK = IE + M
+*
+*              Perform bidiagonal SVD, computing singular values only
+*              (Workspace: need M+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2t (N much larger than M, JOBZ='O')
+*              M right singular vectors to be overwritten on A and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+*
+*              IVT is M by M
+*
+               IL = IVT + M*M
+               IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
+*
+*                 WORK(IL) is M by N
+*
+                  LDWRKL = M
+                  CHUNK = N
+               ELSE
+                  LDWRKL = M
+                  CHUNK = ( LWORK-M*M ) / M
+               END IF
+               ITAU = IL + LDWRKL*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing about above it
+*
+               CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              Generate Q in A
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IL)
+*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+               CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U, and computing right singular
+*              vectors of bidiagonal matrix in WORK(IVT)
+*              (Workspace: need M+M*M+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+     $                      WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
+     $                      IWORK, INFO )
+*
+*              Overwrite U by left singular vectors of L and WORK(IVT)
+*              by right singular vectors of L
+*              (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), WORK( IVT ), M,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IVT) by Q
+*              in A, storing result in WORK(IL) and copying to A
+*              (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+               DO 30 I = 1, N, CHUNK
+                  BLK = MIN( N-I+1, CHUNK )
+                  CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
+     $                        A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
+                  CALL SLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
+     $                         A( 1, I ), LDA )
+   30          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Path 3t (N much larger than M, JOBZ='S')
+*              M right singular vectors to be computed in VT and
+*              M left singular vectors to be computed in U
+*
+               IL = 1
+*
+*              WORK(IL) is M by M
+*
+               LDWRKL = M
+               ITAU = IL + LDWRKL*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing out above it
+*
+               CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              Generate Q in A
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = ITAU
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IU), copying result to U
+*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+               CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need M+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of L and VT
+*              by right singular vectors of L
+*              (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IL) by
+*              Q in A, storing result in VT
+*              (Workspace: need M*M)
+*
+               CALL SLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
+               CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
+     $                     A, LDA, ZERO, VT, LDVT )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 4t (N much larger than M, JOBZ='A')
+*              N right singular vectors to be computed in VT and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+*
+*              WORK(IVT) is M by M
+*
+               LDWKVT = M
+               ITAU = IVT + LDWKVT*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q, copying result to VT
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*              Generate Q in VT
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce L in A, zeroing out other entries
+*
+               CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+               IE = ITAU
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+               CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in WORK(IVT)
+*              (Workspace: need M+M*M+BDSPAC)
+*
+               CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+     $                      WORK( IVT ), LDWKVT, DUM, IDUM,
+     $                      WORK( NWORK ), IWORK, INFO )
+*
+*              Overwrite U by left singular vectors of L and WORK(IVT)
+*              by right singular vectors of L
+*              (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
+     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IVT) by
+*              Q in VT, storing result in A
+*              (Workspace: need M*M)
+*
+               CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
+     $                     VT, LDVT, ZERO, A, LDA )
+*
+*              Copy right singular vectors of A from A to VT
+*
+               CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+            END IF
+*
+         ELSE
+*
+*           N .LT. MNTHR
+*
+*           Path 5t (N greater than M, but not much larger)
+*           Reduce to bidiagonal form without LQ decomposition
+*
+            IE = 1
+            ITAUQ = IE + M
+            ITAUP = ITAUQ + M
+            NWORK = ITAUP + M
+*
+*           Bidiagonalize A
+*           (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+            CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Perform bidiagonal SVD, only computing singular values
+*              (Workspace: need M+BDSPAC)
+*
+               CALL SBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               LDWKVT = M
+               IVT = NWORK
+               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+*                 WORK( IVT ) is M by N
+*
+                  CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
+     $                         LDWKVT )
+                  NWORK = IVT + LDWKVT*N
+               ELSE
+*
+*                 WORK( IVT ) is M by M
+*
+                  NWORK = IVT + LDWKVT*M
+                  IL = NWORK
+*
+*                 WORK(IL) is M by CHUNK
+*
+                  CHUNK = ( LWORK-M*M-3*M ) / M
+               END IF
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in WORK(IVT)
+*              (Workspace: need M*M+BDSPAC)
+*
+               CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
+     $                      WORK( IVT ), LDWKVT, DUM, IDUM,
+     $                      WORK( NWORK ), IWORK, INFO )
+*
+*              Overwrite U by left singular vectors of A
+*              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+*                 Overwrite WORK(IVT) by left singular vectors of A
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+     $                         WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Copy right singular vectors of A from WORK(IVT) to A
+*
+                  CALL SLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
+               ELSE
+*
+*                 Generate P**T in A
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by right singular vectors of
+*                 bidiagonal matrix in WORK(IVT), storing result in
+*                 WORK(IL) and copying to A
+*                 (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+                  DO 40 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
+     $                           LDWKVT, A( 1, I ), LDA, ZERO,
+     $                           WORK( IL ), M )
+                     CALL SLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
+     $                            LDA )
+   40             CONTINUE
+               END IF
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need M+BDSPAC)
+*
+               CALL SLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
+               CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need 3*M, prefer 2*M+M*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE IF( WNTQA ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in U and computing right singular
+*              vectors of bidiagonal matrix in VT
+*              (Workspace: need M+BDSPAC)
+*
+               CALL SLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
+               CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+     $                      LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+     $                      INFO )
+*
+*              Set the right corner of VT to identity matrix
+*
+               IF( N.GT.M ) THEN
+                  CALL SLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
+     $                         LDVT )
+               END IF
+*
+*              Overwrite U by left singular vectors of A and VT
+*              by right singular vectors of A
+*              (Workspace: need 2*M+N, prefer 2*M+N*NB)
+*
+               CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+               CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ISCL.EQ.1 ) THEN
+         IF( ANRM.GT.BIGNUM )
+     $      CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+      END IF
+*
+*     Return optimal workspace in WORK(1)
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of SGESDD
+*
+      END
diff --git a/SRC/sgesv.f b/SRC/sgesv.f
new file mode 100644
index 00000000..acb2f912
--- /dev/null
+++ b/SRC/sgesv.f
@@ -0,0 +1,107 @@
+      SUBROUTINE SGESV( 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( * )
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGESV 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) REAL 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) REAL 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           SGETRF, SGETRS, 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( 'SGESV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of A.
+*
+      CALL SGETRF( N, N, A, LDA, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
+     $                INFO )
+      END IF
+      RETURN
+*
+*     End of SGESV
+*
+      END
diff --git a/SRC/sgesvd.f b/SRC/sgesvd.f
new file mode 100644
index 00000000..6217d039
--- /dev/null
+++ b/SRC/sgesvd.f
@@ -0,0 +1,3402 @@
+      SUBROUTINE SGESVD( 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 ..
+      REAL               A( LDA, * ), S( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGESVD 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) REAL 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) REAL array, dimension (min(M,N))
+*          The singular values of A, sorted so that S(i) >= S(i+1).
+*
+*  U       (output) REAL 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) REAL 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) REAL 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 SBDSQR 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. 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
+      REAL               ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SBDSQR, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
+     $                   SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. 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 SBDSQR
+*
+            MNTHR = ILAENV( 6, 'SGESVD', 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, 'SGEQRF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 3*N+2*N*
+     $                     ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  IF( WNTVO .OR. WNTVAS )
+     $               MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+     $                        ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTUS .OR. WNTUO )
+     $            MAXWRK = MAX( MAXWRK, 3*N+N*
+     $                     ILAENV( 1, 'SORGBR', 'Q', M, N, N, -1 ) )
+               IF( WNTUA )
+     $            MAXWRK = MAX( MAXWRK, 3*N+M*
+     $                     ILAENV( 1, 'SORGBR', 'Q', M, M, N, -1 ) )
+               IF( .NOT.WNTVN )
+     $            MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+     $                     ILAENV( 1, 'SORGBR', '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 SBDSQR
+*
+            MNTHR = ILAENV( 6, 'SGESVD', 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, 'SGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M+2*M*
+     $                     ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  IF( WNTUO .OR. WNTUAS )
+     $               MAXWRK = MAX( MAXWRK, 3*M+M*
+     $                        ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = 2*M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               ELSE IF( WNTVS .AND. WNTUAS ) THEN
+*
+*                 Path 6t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'SORGBR', '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, 'SGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTVS .OR. WNTVO )
+     $            MAXWRK = MAX( MAXWRK, 3*M+M*
+     $                     ILAENV( 1, 'SORGBR', 'P', M, N, M, -1 ) )
+               IF( WNTVA )
+     $            MAXWRK = MAX( MAXWRK, 3*M+N*
+     $                     ILAENV( 1, 'SORGBR', 'P', N, N, M, -1 ) )
+               IF( .NOT.WNTUN )
+     $            MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
+     $                     ILAENV( 1, 'SORGBR', '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( 'SGESVD', -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 = SLAMCH( 'P' )
+      SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL SLASCL( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL SLASET( '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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SLACPY( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to WORK(IR) and zero out below it
+*
+                  CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+                  CALL SLASET( '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 SORGQR( 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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL SLACPY( '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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL SLASET( '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 SORGQR( 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 SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL SLACPY( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            VT( 2, 1 ), LDVT )
+*
+*                 Generate Q in A
+*                 (Workspace: need 2*N, prefer N+N*NB)
+*
+                  CALL SORGQR( 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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL SLASET( '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 SORGQR( 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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL SORGQR( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SORGQR( 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 SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL SORGQR( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SORGQR( 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 SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to VT, zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL SLASET( '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 SORGQR( 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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N+M, prefer N+M*NB)
+*
+                     CALL SORGQR( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+*                    Copy right singular vectors of R from WORK(IR) to A
+*
+                     CALL SLACPY( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N+M, prefer N+M*NB)
+*
+                     CALL SORGQR( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+                     CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( '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 SGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N+M, prefer N+M*NB)
+*
+                     CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R from A to VT, zeroing out below it
+*
+                     CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGEBRD( 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 SLACPY( 'L', M, N, A, LDA, U, LDU )
+               IF( WNTUS )
+     $            NCU = N
+               IF( WNTUA )
+     $            NCU = M
+               CALL SORGBR( '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 SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL SORGBR( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SBDSQR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL SLASET( '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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SLACPY( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to WORK(IR) and zero out above it
+*
+                  CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+                  CALL SLASET( '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 SORGLQ( 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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL SLACPY( '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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing about above it
+*
+                  CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL SLASET( '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 SORGLQ( 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 SGEBRD( M, M, U, LDU, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL SLACPY( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing out above it
+*
+                  CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+     $                         LDU )
+*
+*                 Generate Q in A
+*                 (Workspace: need 2*M, prefer M+M*NB)
+*
+                  CALL SORGLQ( 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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL SLASET( '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 SORGLQ( 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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy result to VT
+*
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL SORGLQ( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out below it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SORGLQ( 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 SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL SORGLQ( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SORGLQ( 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 SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL SLASET( '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 SORGLQ( 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 SGEBRD( 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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M+N, prefer M+N*NB)
+*
+                     CALL SORGLQ( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy left singular vectors of A from WORK(IR) to A
+*
+                     CALL SLACPY( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M+N, prefer M+N*NB)
+*
+                     CALL SORGLQ( 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 SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+                     CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL SLASET( '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 SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL SLACPY( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SGEMM( '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 SLACPY( '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 SGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M+N, prefer M+N*NB)
+*
+                     CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL SLASET( '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 SGEBRD( 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 SORMBR( '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 SORGBR( '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 SBDSQR( '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 SGEBRD( 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 SLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL SORGBR( '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 SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               IF( WNTVA )
+     $            NRVT = N
+               IF( WNTVS )
+     $            NRVT = M
+               CALL SORGBR( '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 SORGBR( '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 SORGBR( '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 SBDSQR( '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 SBDSQR( '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 SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+     $                      LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     If SBDSQR 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 SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+     $      CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+     $                   MINMN, IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+     $      CALL SLASCL( '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 SGESVD
+*
+      END
diff --git a/SRC/sgesvx.f b/SRC/sgesvx.f
new file mode 100644
index 00000000..24dc987b
--- /dev/null
+++ b/SRC/sgesvx.f
@@ -0,0 +1,479 @@
+      SUBROUTINE SGESVX( 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
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGESVX 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) REAL 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) REAL 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 SGETRF.  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 SGETRF; 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL
+*          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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+      CHARACTER          NORM
+      INTEGER            I, INFEQU, J
+      REAL               AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANGE, SLANTR
+      EXTERNAL           LSAME, SLAMCH, SLANGE, SLANTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGECON, SGEEQU, SGERFS, SGETRF, SGETRS, SLACPY,
+     $                   SLAQGE, 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 = SLAMCH( '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( 'SGESVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL SGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL SLAQGE( 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 SLACPY( 'Full', N, N, A, LDA, AF, LDAF )
+         CALL SGETRF( 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 = SLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
+     $               WORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = SLANGE( '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 = SLANGE( NORM, N, N, A, LDA, WORK )
+      RPVGRW = SLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = SLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SGETRS( 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 SGERFS( 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
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of SGESVX
+*
+      END
diff --git a/SRC/sgetc2.f b/SRC/sgetc2.f
new file mode 100644
index 00000000..db52cff6
--- /dev/null
+++ b/SRC/sgetc2.f
@@ -0,0 +1,146 @@
+      SUBROUTINE SGETC2( 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( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETC2 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IP, IPV, J, JP, JPV
+      REAL               BIGNUM, EPS, SMIN, SMLNUM, XMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGER, SLABAD, SSWAP
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Set constants to control overflow
+*
+      INFO = 0
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( 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 SSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
+         IPIV( I ) = IPV
+*
+*        Swap columns
+*
+         IF( JPV.NE.I )
+     $      CALL SSWAP( 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 SGER( 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 SGETC2
+*
+      END
diff --git a/SRC/sgetf2.f b/SRC/sgetf2.f
new file mode 100644
index 00000000..d5a045d5
--- /dev/null
+++ b/SRC/sgetf2.f
@@ -0,0 +1,147 @@
+      SUBROUTINE SGETF2( 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( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETF2 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               SFMIN
+      INTEGER            I, J, JP
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      INTEGER            ISAMAX
+      EXTERNAL           SLAMCH, ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGER, SSCAL, SSWAP, 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( 'SGETF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Compute machine safe minimum 
+* 
+      SFMIN = SLAMCH('S')
+*
+      DO 10 J = 1, MIN( M, N )
+*
+*        Find pivot and test for singularity.
+*
+         JP = J - 1 + ISAMAX( 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 SSWAP( 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 SSCAL( 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 SGER( 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 SGETF2
+*
+      END
diff --git a/SRC/sgetrf.f b/SRC/sgetrf.f
new file mode 100644
index 00000000..7f3c90a6
--- /dev/null
+++ b/SRC/sgetrf.f
@@ -0,0 +1,159 @@
+      SUBROUTINE SGETRF( 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( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETRF 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SGETF2, SLASWP, STRSM, 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( 'SGETRF', -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, 'SGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL SGETF2( 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 SGETF2( 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 SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply interchanges to columns J+JB:N.
+*
+               CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
+     $                      IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL STRSM( '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 SGEMM( '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 SGETRF
+*
+      END
diff --git a/SRC/sgetri.f b/SRC/sgetri.f
new file mode 100644
index 00000000..3eb1f346
--- /dev/null
+++ b/SRC/sgetri.f
@@ -0,0 +1,192 @@
+      SUBROUTINE SGETRI( 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( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETRI computes the inverse of a matrix using the LU factorization
+*  computed by SGETRF.
+*
+*  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) REAL array, dimension (LDA,N)
+*          On entry, the factors L and U from the factorization
+*          A = P*L*U as computed by SGETRF.
+*          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 SGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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           SGEMM, SGEMV, SSWAP, STRSM, STRTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NB = ILAENV( 1, 'SGETRI', ' ', 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( 'SGETRI', -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 STRTRI, then U is singular,
+*     and the inverse is not computed.
+*
+      CALL STRTRI( '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, 'SGETRI', ' ', 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 SGEMV( '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 SGEMM( '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 STRSM( '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 SSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
+   60 CONTINUE
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of SGETRI
+*
+      END
diff --git a/SRC/sgetrs.f b/SRC/sgetrs.f
new file mode 100644
index 00000000..3c82cf87
--- /dev/null
+++ b/SRC/sgetrs.f
@@ -0,0 +1,149 @@
+      SUBROUTINE SGETRS( 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( * )
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGETRS 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 SGETRF.
+*
+*  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) REAL array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by SGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from SGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASWP, STRSM, 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( 'SGETRS', -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 SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
+*
+*        Solve L*X = B, overwriting B with X.
+*
+         CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL STRSM( '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 STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
+     $               A, LDA, B, LDB )
+*
+*        Apply row interchanges to the solution vectors.
+*
+         CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
+      END IF
+*
+      RETURN
+*
+*     End of SGETRS
+*
+      END
diff --git a/SRC/sggbak.f b/SRC/sggbak.f
new file mode 100644
index 00000000..fddd264e
--- /dev/null
+++ b/SRC/sggbak.f
@@ -0,0 +1,220 @@
+      SUBROUTINE SGGBAK( 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 ..
+      REAL               LSCALE( * ), RSCALE( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGBAK 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
+*  SGGBAL.
+*
+*  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 SGGBAL.
+*
+*  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 SGGBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  LSCALE  (input) REAL array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the left side of A and B, as returned by SGGBAL.
+*
+*  RSCALE  (input) REAL array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the right side of A and B, as returned by SGGBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) REAL array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by STGEVC.
+*          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           SSCAL, SSWAP, 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( 'SGGBAK', -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 SSCAL( 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 SSCAL( 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 SSWAP( 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 SSWAP( 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 SSWAP( 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 SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+  100       CONTINUE
+         END IF
+      END IF
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of SGGBAK
+*
+      END
diff --git a/SRC/sggbal.f b/SRC/sggbal.f
new file mode 100644
index 00000000..9c82f373
--- /dev/null
+++ b/SRC/sggbal.f
@@ -0,0 +1,469 @@
+      SUBROUTINE SGGBAL( 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 ..
+      REAL               A( LDA, * ), B( LDB, * ), LSCALE( * ),
+     $                   RSCALE( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGBAL 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) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+      REAL               THREE, SCLFAC
+      PARAMETER          ( THREE = 3.0E+0, SCLFAC = 1.0E+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
+      REAL               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            ISAMAX
+      REAL               SDOT, SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SSCAL, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG10, MAX, MIN, REAL, 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( 'SGGBAL', -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 SSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
+      CALL SSWAP( 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 SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL SSWAP( 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 / REAL( 2*NR )
+      COEF2 = COEF*COEF
+      COEF5 = HALF*COEF2
+      NRP2 = NR + 2
+      BETA = ZERO
+      IT = 1
+*
+*     Start generalized conjugate gradient iteration
+*
+  250 CONTINUE
+*
+      GAMMA = SDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
+     $        SDOT( 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 SSCAL( NR, BETA, WORK( ILO ), 1 )
+      CALL SSCAL( NR, BETA, WORK( ILO+N ), 1 )
+*
+      CALL SAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
+      CALL SAXPY( 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 ) = REAL( 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 ) = REAL( KOUNT )*WORK( J ) + SUM
+  330 CONTINUE
+*
+      SUM = SDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
+     $      SDOT( 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 SAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
+      CALL SAXPY( 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 = SLAMCH( 'S' )
+      SFMAX = ONE / SFMIN
+      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
+      LSFMAX = INT( LOG10( SFMAX ) / BASL )
+      DO 360 I = ILO, IHI
+         IRAB = ISAMAX( N-ILO+1, A( I, ILO ), LDA )
+         RAB = ABS( A( I, IRAB+ILO-1 ) )
+         IRAB = ISAMAX( 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 = ISAMAX( IHI, A( 1, I ), 1 )
+         CAB = ABS( A( ICAB, I ) )
+         ICAB = ISAMAX( 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 SSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
+         CALL SSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
+  370 CONTINUE
+*
+*     Column scaling of matrices A and B
+*
+      DO 380 J = ILO, IHI
+         CALL SSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
+         CALL SSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
+  380 CONTINUE
+*
+      RETURN
+*
+*     End of SGGBAL
+*
+      END
diff --git a/SRC/sgges.f b/SRC/sgges.f
new file mode 100644
index 00000000..00f16a5e
--- /dev/null
+++ b/SRC/sgges.f
@@ -0,0 +1,558 @@
+      SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
+     $                  SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
+     $                  LDVSR, WORK, LWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.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( * )
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+     $                   VSR( LDVSR, * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGES 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
+*  SGGEV 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 SELCTG);
+*
+*  SELCTG  (external procedure) LOGICAL FUNCTION of three REAL arguments
+*          SELCTG must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'N', SELCTG is not referenced.
+*          If SORT = 'S', SELCTG is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+*          one of a complex conjugate pair of eigenvalues is selected,
+*          then both complex eigenvalues are selected.
+*
+*          Note that in the ill-conditioned case, a selected complex
+*          eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
+*          BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
+*          in this case.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VSL, and VSR.  N >= 0.
+*
+*  A       (input/output) REAL 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) REAL 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.  (Complex conjugate pairs for which
+*          SELCTG is true for either eigenvalue count as 2.)
+*
+*  ALPHAR  (output) REAL array, dimension (N)
+*  ALPHAI  (output) REAL array, dimension (N)
+*  BETA    (output) REAL 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) REAL 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) REAL 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) REAL 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 N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).
+*          For good performance , LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  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 SHGEQZ.
+*                =N+2: after reordering, roundoff changed values of
+*                      some complex eigenvalues so that leading
+*                      eigenvalues in the Generalized Schur form no
+*                      longer satisfy SELCTG=.TRUE.  This could also
+*                      be caused due to scaling.
+*                =N+3: reordering failed in STGSEN.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
+     $                   PVSR, SAFMAX, SAFMIN, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      REAL               DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+     $                   SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVSL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVSL = .FALSE.
+      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVSL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVSL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVSR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVSR = .FALSE.
+      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVSR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVSR = .FALSE.
+      END IF
+*
+      WANTST = LSAME( SORT, 'S' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -15
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -17
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.GT.0 )THEN
+            MINWRK = MAX( 8*N, 6*N + 16 )
+            MAXWRK = MINWRK - N +
+     $               N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 )
+            MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $                    N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) )
+            IF( ILVSL ) THEN
+               MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $                       N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) )
+            END IF
+         ELSE
+            MINWRK = 1
+            MAXWRK = 1
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+     $      INFO = -19
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGES ', -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 = SLAMCH( 'P' )
+      SAFMIN = SLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      SMLNUM = SQRT( SAFMIN ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = SLANGE( '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 SLASCL( '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 SGGBAL( '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 SGEQRF( 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 SORMQR( '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 SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL SGGHRD( 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 SHGEQZ( '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 40
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA if desired
+*     (Workspace: need 4*N+16 )
+*
+      SDIM = 0
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before SELCTGing
+*
+         IF( ILASCL ) THEN
+            CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                   IERR )
+            CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+     $                   IERR )
+         END IF
+         IF( ILBSCL )
+     $      CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+   10    CONTINUE
+*
+         CALL STGSEN( 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 SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+      IF( ILVSR )
+     $   CALL SGGBAK( '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 50 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
+   50    CONTINUE
+      END IF 
+*
+      IF( ILBSCL )THEN 
+         DO 60 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
+   60    CONTINUE 
+      END IF 
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL SLASCL( '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 30 I = 1, N
+            CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+            IF( ALPHAI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   30    CONTINUE
+*
+      END IF
+*
+   40 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of SGGES
+*
+      END
diff --git a/SRC/sggesx.f b/SRC/sggesx.f
new file mode 100644
index 00000000..241bc660
--- /dev/null
+++ b/SRC/sggesx.f
@@ -0,0 +1,676 @@
+      SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
+     $                   B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL,
+     $                   VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK,
+     $                   LIWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVSL, JOBVSR, SENSE, SORT
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
+     $                   SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), RCONDE( 2 ),
+     $                   RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGESX computes for a pair of N-by-N real nonsymmetric matrices
+*  (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
+*  optionally, the left and/or right matrices of Schur vectors (VSL and
+*  VSR).  This gives the generalized Schur factorization
+*
+*       (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
+*
+*  Optionally, it also orders the eigenvalues so that a selected cluster
+*  of eigenvalues appears in the leading diagonal blocks of the upper
+*  quasi-triangular matrix S and the upper triangular matrix T; computes
+*  a reciprocal condition number for the average of the selected
+*  eigenvalues (RCONDE); and computes a reciprocal condition number for
+*  the right and left deflating subspaces corresponding to the selected
+*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form
+*  an orthonormal basis for the corresponding left and right eigenspaces
+*  (deflating subspaces).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
+*  usually represented as the pair (alpha,beta), as there is a
+*  reasonable interpretation for beta=0 or for both being zero.
+*
+*  A pair of matrices (S,T) is in generalized real Schur form if T is
+*  upper triangular with non-negative diagonal and S is block upper
+*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
+*  to real generalized eigenvalues, while 2-by-2 blocks of S will be
+*  "standardized" by making the corresponding elements of T have the
+*  form:
+*          [  a  0  ]
+*          [  0  b  ]
+*
+*  and the pair of corresponding 2-by-2 blocks in S and T will have a
+*  complex conjugate pair of generalized eigenvalues.
+*
+*
+*  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 three REAL arguments
+*          SELCTG must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'N', SELCTG is not referenced.
+*          If SORT = 'S', SELCTG is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+*          one of a complex conjugate pair of eigenvalues is selected,
+*          then both complex eigenvalues are selected.
+*          Note that a selected complex eigenvalue may no longer satisfy
+*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
+*          since ordering may change the value of complex eigenvalues
+*          (especially if the eigenvalue is ill-conditioned), in this
+*          case INFO is set to N+3.
+*
+*  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 deflating subspaces only;
+*          = 'B' : Computed for both.
+*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VSL, and VSR.  N >= 0.
+*
+*  A       (input/output) REAL 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) REAL 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.  (Complex conjugate pairs for which
+*          SELCTG is true for either eigenvalue count as 2.)
+*
+*  ALPHAR  (output) REAL array, dimension (N)
+*  ALPHAI  (output) REAL array, dimension (N)
+*  BETA    (output) REAL 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) REAL 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) REAL 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.
+*
+*  RCONDE  (output) REAL array, dimension ( 2 )
+*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
+*          reciprocal condition numbers for the average of the selected
+*          eigenvalues.
+*          Not referenced if SENSE = 'N' or 'V'.
+*
+*  RCONDV  (output) REAL array, dimension ( 2 )
+*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
+*          reciprocal condition numbers for the selected deflating
+*          subspaces.
+*          Not referenced if SENSE = 'N' or 'E'.
+*
+*  WORK    (workspace/output) REAL 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 N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
+*          LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
+*          LWORK >= max( 8*N, 6*N+16 ).
+*          Note that 2*SDIM*(N-SDIM) <= N*N/2.
+*          Note also that an error is only returned if
+*          LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
+*          this may not be large enough.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the bound on the optimal size of the WORK
+*          array and the minimum size of the IWORK array, returns these
+*          values as the first entries of the WORK and IWORK arrays, and
+*          no error message related to LWORK or LIWORK is issued by
+*          XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
+*          LIWORK >= N+6.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the bound on the optimal size of the
+*          WORK array and the minimum size of the IWORK array, returns
+*          these values as the first entries of the WORK and IWORK
+*          arrays, and no error message related to LWORK or LIWORK is
+*          issued by XERBLA.
+*
+*  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 SHGEQZ
+*                =N+2: after reordering, roundoff changed values of
+*                      some complex eigenvalues so that leading
+*                      eigenvalues in the Generalized Schur form no
+*                      longer satisfy SELCTG=.TRUE.  This could also
+*                      be caused due to scaling.
+*                =N+3: reordering failed in STGSEN.
+*
+*  Further details
+*  ===============
+*
+*  An approximate (asymptotic) bound on the average absolute error of
+*  the selected eigenvalues is
+*
+*       EPS * norm((A, B)) / RCONDE( 1 ).
+*
+*  An approximate (asymptotic) bound on the maximum angular error in
+*  the computed deflating subspaces is
+*
+*       EPS * norm((A, B)) / RCONDV( 2 ).
+*
+*  See LAPACK User's Guide, section 4.11 for more information.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+     $                   LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST,
+     $                   WANTSV
+      INTEGER            I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
+     $                   ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK,
+     $                   LIWMIN, LWRK, MAXWRK, MINWRK
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
+     $                   PR, SAFMAX, SAFMIN, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      REAL               DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+     $                   SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVSL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVSL = .FALSE.
+      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVSL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVSL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVSR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVSR = .FALSE.
+      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVSR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVSR = .FALSE.
+      END IF
+*
+      WANTST = LSAME( SORT, 'S' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+      IF( WANTSN ) THEN
+         IJOB = 0
+      ELSE IF( WANTSE ) THEN
+         IJOB = 1
+      ELSE IF( WANTSV ) THEN
+         IJOB = 2
+      ELSE IF( WANTSB ) THEN
+         IJOB = 4
+      END IF
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+     $         ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -16
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -18
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.GT.0) THEN
+            MINWRK = MAX( 8*N, 6*N + 16 )
+            MAXWRK = MINWRK - N +
+     $               N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 )
+            MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $               N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) )
+            IF( ILVSL ) THEN
+               MAXWRK = MAX( MAXWRK, MINWRK - N +
+     $                  N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) )
+            END IF
+            LWRK = MAXWRK
+            IF( IJOB.GE.1 )
+     $         LWRK = MAX( LWRK, N*N/2 )
+         ELSE
+            MINWRK = 1
+            MAXWRK = 1
+            LWRK   = 1
+         END IF
+         WORK( 1 ) = LWRK
+         IF( WANTSN .OR. N.EQ.0 ) THEN
+            LIWMIN = 1
+         ELSE
+            LIWMIN = N + 6
+         END IF
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -22
+         ELSE IF( LIWORK.LT.LIWMIN  .AND. .NOT.LQUERY ) THEN
+            INFO = -24
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGESX', -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 = SLAMCH( 'P' )
+      SAFMIN = SLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      SMLNUM = SQRT( SAFMIN ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = SLANGE( '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 SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (Workspace: need 6*N + 2*N for permutation parameters)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWRK = IRIGHT + N
+      CALL SGGBAL( '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 SGEQRF( 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 SORMQR( '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 SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+     $             LDVSL, VSR, LDVSR, IERR )
+*
+      SDIM = 0
+*
+*     Perform QZ algorithm, computing Schur vectors if desired
+*     (Workspace: need N)
+*
+      IWRK = ITAU
+      CALL SHGEQZ( '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 and compute the reciprocal of
+*     condition number(s)
+*     (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
+*                 otherwise, need 8*(N+1) )
+*
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before SELCTGing
+*
+         IF( ILASCL ) THEN
+            CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                   IERR )
+            CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+     $                   IERR )
+         END IF
+         IF( ILBSCL )
+     $      CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues, transform Generalized Schur vectors, and
+*        compute reciprocal condition numbers
+*
+         CALL STGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
+     $                ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+     $                SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1,
+     $                IWORK, LIWORK, IERR )
+*
+         IF( IJOB.GE.1 )
+     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+         IF( IERR.EQ.-22 ) THEN
+*
+*            not enough real workspace
+*
+            INFO = -22
+         ELSE
+            IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
+               RCONDE( 1 ) = PL
+               RCONDE( 2 ) = PR
+            END IF
+            IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+               RCONDV( 1 ) = DIF( 1 )
+               RCONDV( 2 ) = DIF( 2 )
+            END IF
+            IF( IERR.EQ.1 )
+     $         INFO = N + 3
+         END IF
+*
+      END IF
+*
+*     Apply permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+      IF( ILVSR )
+     $   CALL SGGBAK( '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 25 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 
+   25    CONTINUE
+      END IF 
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+      IF( WANTST ) THEN
+*
+*        Check if reordering is correct
+*
+         LASTSL = .TRUE.
+         LST2SL = .TRUE.
+         SDIM = 0
+         IP = 0
+         DO 40 I = 1, N
+            CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+            IF( ALPHAI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   40    CONTINUE
+*
+      END IF
+*
+   50 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of SGGESX
+*
+      END
diff --git a/SRC/sggev.f b/SRC/sggev.f
new file mode 100644
index 00000000..59dbe214
--- /dev/null
+++ b/SRC/sggev.f
@@ -0,0 +1,489 @@
+      SUBROUTINE SGGEV( 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 ..
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGEV 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) REAL 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) REAL 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) REAL array, dimension (N)
+*  ALPHAI  (output) REAL array, dimension (N)
+*  BETA    (output) REAL 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) REAL 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) REAL 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) REAL 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 SHGEQZ.
+*                =N+2: error return from STGEVC.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+     $                   SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. 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, 'SGEQRF', ' ', N, 1, N, 0 ) ) )
+         MAXWRK = MAX( MAXWRK, N*( 7 +
+     $                 ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) ) )
+         IF( ILVL ) THEN
+            MAXWRK = MAX( MAXWRK, N*( 7 +
+     $                 ILAENV( 1, 'SORGQR', ' ', 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( 'SGGEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = SLANGE( '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 SLASCL( '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 SGGBAL( '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 SGEQRF( 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 SORMQR( '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 SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VR
+*
+      IF( ILVR )
+     $   CALL SLASET( '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 SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL SGGHRD( '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 SHGEQZ( 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 STGEVC( 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 SGGBAK( '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 SGGBAK( '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 SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+  110 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of SGGEV
+*
+      END
diff --git a/SRC/sggevx.f b/SRC/sggevx.f
new file mode 100644
index 00000000..622ac998
--- /dev/null
+++ b/SRC/sggevx.f
@@ -0,0 +1,716 @@
+      SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
+     $                   ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO,
+     $                   IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE,
+     $                   RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+      REAL               ABNRM, BBNRM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), LSCALE( * ),
+     $                   RCONDE( * ), RCONDV( * ), RSCALE( * ),
+     $                   VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+*  the generalized eigenvalues, and optionally, the left and/or right
+*  generalized eigenvectors.
+*
+*  Optionally also, it computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
+*  the eigenvalues (RCONDE), and reciprocal condition numbers for the
+*  right eigenvectors (RCONDV).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+*  singular. It is usually represented as the pair (alpha,beta), as
+*  there is a reasonable interpretation for beta=0, and even for both
+*  being zero.
+*
+*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*
+*                   A * v(j) = lambda(j) * B * v(j) .
+*
+*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*
+*                   u(j)**H * A  = lambda(j) * u(j)**H * B.
+*
+*  where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Specifies the balance option to be performed.
+*          = 'N':  do not diagonally scale or permute;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*          Computed reciprocal condition numbers will be for the
+*          matrices after permuting and/or balancing. Permuting does
+*          not change condition numbers (in exact arithmetic), but
+*          balancing does.
+*
+*  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.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': none are computed;
+*          = 'E': computed for eigenvalues only;
+*          = 'V': computed for eigenvectors only;
+*          = 'B': computed for eigenvalues and eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VL, and VR.  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA, N)
+*          On entry, the matrix A in the pair (A,B).
+*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
+*          or both, then A contains the first part of the real Schur
+*          form of the "balanced" versions of the input A and B.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) REAL array, dimension (LDB, N)
+*          On entry, the matrix B in the pair (A,B).
+*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
+*          or both, then B contains the second part of the real Schur
+*          form of the "balanced" versions of the input A and B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHAR  (output) REAL array, dimension (N)
+*  ALPHAI  (output) REAL array, dimension (N)
+*  BETA    (output) REAL 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) REAL array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored one
+*          after another in the columns of VL, in the same order as
+*          their eigenvalues. If the j-th eigenvalue is real, then
+*          u(j) = VL(:,j), the j-th column of VL. If the j-th and
+*          (j+1)-th eigenvalues form a complex conjugate pair, then
+*          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
+*          Each eigenvector will be scaled so the largest component have
+*          abs(real part) + abs(imag. part) = 1.
+*          Not referenced if JOBVL = 'N'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the matrix VL. LDVL >= 1, and
+*          if JOBVL = 'V', LDVL >= N.
+*
+*  VR      (output) REAL array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right eigenvectors v(j) are stored one
+*          after another in the columns of VR, in the same order as
+*          their eigenvalues. If the j-th eigenvalue is real, then
+*          v(j) = VR(:,j), the j-th column of VR. If the j-th and
+*          (j+1)-th eigenvalues form a complex conjugate pair, then
+*          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
+*          Each eigenvector will be scaled so the largest component have
+*          abs(real part) + abs(imag. part) = 1.
+*          Not referenced if JOBVR = 'N'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the matrix VR. LDVR >= 1, and
+*          if JOBVR = 'V', LDVR >= N.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values such that on exit
+*          A(i,j) = 0 and B(i,j) = 0 if i > j and
+*          j = 1,...,ILO-1 or i = IHI+1,...,N.
+*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  LSCALE  (output) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the left side of A and B.  If PL(j) is the index of the
+*          row interchanged with row j, and DL(j) is the scaling
+*          factor applied to row j, then
+*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1
+*                      = DL(j)  for j = ILO,...,IHI
+*                      = PL(j)  for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  RSCALE  (output) REAL array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the right side of A and B.  If PR(j) is the index of the
+*          column interchanged with column j, and DR(j) is the scaling
+*          factor applied to column j, then
+*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1
+*                      = DR(j)  for j = ILO,...,IHI
+*                      = PR(j)  for j = IHI+1,...,N
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) REAL
+*          The one-norm of the balanced matrix A.
+*
+*  BBNRM   (output) REAL
+*          The one-norm of the balanced matrix B.
+*
+*  RCONDE  (output) REAL array, dimension (N)
+*          If SENSE = 'E' or 'B', the reciprocal condition numbers of
+*          the eigenvalues, stored in consecutive elements of the array.
+*          For a complex conjugate pair of eigenvalues two consecutive
+*          elements of RCONDE are set to the same value. Thus RCONDE(j),
+*          RCONDV(j), and the j-th columns of VL and VR all correspond
+*          to the j-th eigenpair.
+*          If SENSE = 'N' or 'V', RCONDE is not referenced.
+*
+*  RCONDV  (output) REAL array, dimension (N)
+*          If SENSE = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the eigenvectors, stored in consecutive elements
+*          of the array. For a complex eigenvector two consecutive
+*          elements of RCONDV are set to the same value. If the
+*          eigenvalues cannot be reordered to compute RCONDV(j),
+*          RCONDV(j) is set to 0; this can only occur when the true
+*          value would be very small anyway.
+*          If SENSE = 'N' or 'E', RCONDV is not referenced.
+*
+*  WORK    (workspace/output) REAL 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).
+*          If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
+*          LWORK >= max(1,6*N).
+*          If SENSE = 'E', LWORK >= max(1,10*N).
+*          If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N+6)
+*          If SENSE = 'E', IWORK is not referenced.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          If SENSE = 'N', BWORK is not referenced.
+*
+*  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 SHGEQZ.
+*                =N+2: error return from STGEVC.
+*
+*  Further Details
+*  ===============
+*
+*  Balancing a matrix pair (A,B) includes, first, permuting rows and
+*  columns to isolate eigenvalues, second, applying diagonal similarity
+*  transformation to the rows and columns to make the rows and columns
+*  as close in norm as possible. The computed reciprocal condition
+*  numbers correspond to the balanced matrix. Permuting rows and columns
+*  will not change the condition numbers (in exact arithmetic) but
+*  diagonal scaling will.  For further explanation of balancing, see
+*  section 4.11.1.2 of LAPACK Users' Guide.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
+*
+*  An approximate error bound for the angle between the i-th computed
+*  eigenvector VL(i) or VR(i) is given by
+*
+*       EPS * norm(ABNRM, BBNRM) / DIF(i).
+*
+*  For further explanation of the reciprocal condition numbers RCONDE
+*  and RCONDV, see section 4.11 of LAPACK User's Guide.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
+     $                   PAIR, WANTSB, WANTSE, WANTSN, WANTSV
+      CHARACTER          CHTEMP
+      INTEGER            I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
+     $                   ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK,
+     $                   MINWRK, MM
+      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+     $                   SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
+     $                   STGSNA, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVL = .FALSE.
+      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVR = .FALSE.
+      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVR = .FALSE.
+      END IF
+      ILV = ILVL .OR. ILVR
+*
+      NOSCL  = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.( NOSCL .OR. LSAME( BALANC, 'S' ) .OR.
+     $    LSAME( BALANC, 'B' ) ) ) THEN
+         INFO = -1
+      ELSE IF( IJOBVL.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
+     $          THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -16
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV. The workspace is
+*       computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            IF( NOSCL .AND. .NOT.ILV ) THEN
+               MINWRK = 2*N
+            ELSE
+               MINWRK = 6*N
+            END IF
+            IF( WANTSE ) THEN
+               MINWRK = 10*N
+            ELSE IF( WANTSV .OR. WANTSB ) THEN
+               MINWRK = 2*N*( N + 4 ) + 16
+            END IF
+            MAXWRK = MINWRK
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) )
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) )
+            IF( ILVL ) THEN
+               MAXWRK = MAX( MAXWRK, N +
+     $                       N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, 0 ) )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -26
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = SLANGE( '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 SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = SLANGE( '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 SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute and/or balance the matrix pair (A,B)
+*     (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
+*
+      CALL SGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+     $             WORK, IERR )
+*
+*     Compute ABNRM and BBNRM
+*
+      ABNRM = SLANGE( '1', N, N, A, LDA, WORK( 1 ) )
+      IF( ILASCL ) THEN
+         WORK( 1 ) = ABNRM
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1,
+     $                IERR )
+         ABNRM = WORK( 1 )
+      END IF
+*
+      BBNRM = SLANGE( '1', N, N, B, LDB, WORK( 1 ) )
+      IF( ILBSCL ) THEN
+         WORK( 1 ) = BBNRM
+         CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1,
+     $                IERR )
+         BBNRM = WORK( 1 )
+      END IF
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Workspace: need N, prefer N*NB )
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWRK = ITAU + IROWS
+      CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to A
+*     (Workspace: need N, prefer N*NB)
+*
+      CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VL and/or VR
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVL ) THEN
+         CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+      IF( ILVR )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+      END IF
+*
+*     Perform QZ algorithm (Compute eigenvalues, and optionally, the
+*     Schur forms and Schur vectors)
+*     (Workspace: need N)
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+*
+      CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK,
+     $             LWORK, IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 130
+      END IF
+*
+*     Compute Eigenvectors and estimate condition numbers if desired
+*     (Workspace: STGEVC: need 6*N
+*                 STGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
+*                         need N otherwise )
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         IF( ILV ) THEN
+            IF( ILVL ) THEN
+               IF( ILVR ) THEN
+                  CHTEMP = 'B'
+               ELSE
+                  CHTEMP = 'L'
+               END IF
+            ELSE
+               CHTEMP = 'R'
+            END IF
+*
+            CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, N, IN, WORK, IERR )
+            IF( IERR.NE.0 ) THEN
+               INFO = N + 2
+               GO TO 130
+            END IF
+         END IF
+*
+         IF( .NOT.WANTSN ) THEN
+*
+*           compute eigenvectors (STGEVC) and estimate condition
+*           numbers (STGSNA). Note that the definition of the condition
+*           number is not invariant under transformation (u,v) to
+*           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
+*           Schur form (S,T), Q and Z are orthogonal matrices. In order
+*           to avoid using extra 2*N*N workspace, we have to recalculate
+*           eigenvectors and estimate one condition numbers at a time.
+*
+            PAIR = .FALSE.
+            DO 20 I = 1, N
+*
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+                  GO TO 20
+               END IF
+               MM = 1
+               IF( I.LT.N ) THEN
+                  IF( A( I+1, I ).NE.ZERO ) THEN
+                     PAIR = .TRUE.
+                     MM = 2
+                  END IF
+               END IF
+*
+               DO 10 J = 1, N
+                  BWORK( J ) = .FALSE.
+   10          CONTINUE
+               IF( MM.EQ.1 ) THEN
+                  BWORK( I ) = .TRUE.
+               ELSE IF( MM.EQ.2 ) THEN
+                  BWORK( I ) = .TRUE.
+                  BWORK( I+1 ) = .TRUE.
+               END IF
+*
+               IWRK = MM*N + 1
+               IWRK1 = IWRK + MM*N
+*
+*              Compute a pair of left and right eigenvectors.
+*              (compute workspace: need up to 4*N + 6*N)
+*
+               IF( WANTSE .OR. WANTSB ) THEN
+                  CALL STGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
+     $                         WORK( 1 ), N, WORK( IWRK ), N, MM, M,
+     $                         WORK( IWRK1 ), IERR )
+                  IF( IERR.NE.0 ) THEN
+                     INFO = N + 2
+                     GO TO 130
+                  END IF
+               END IF
+*
+               CALL STGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
+     $                      WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
+     $                      RCONDV( I ), MM, M, WORK( IWRK1 ),
+     $                      LWORK-IWRK1+1, IWORK, IERR )
+*
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Undo balancing on VL and VR and normalization
+*     (Workspace: none needed)
+*
+      IF( ILVL ) THEN
+         CALL SGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
+     $                LDVL, IERR )
+*
+         DO 70 JC = 1, N
+            IF( ALPHAI( JC ).LT.ZERO )
+     $         GO TO 70
+            TEMP = ZERO
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 30 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+   30          CONTINUE
+            ELSE
+               DO 40 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+     $                   ABS( VL( JR, JC+1 ) ) )
+   40          CONTINUE
+            END IF
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 70
+            TEMP = ONE / TEMP
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 50 JR = 1, N
+                  VL( JR, JC ) = VL( JR, JC )*TEMP
+   50          CONTINUE
+            ELSE
+               DO 60 JR = 1, N
+                  VL( JR, JC ) = VL( JR, JC )*TEMP
+                  VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+   60          CONTINUE
+            END IF
+   70    CONTINUE
+      END IF
+      IF( ILVR ) THEN
+         CALL SGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
+     $                LDVR, IERR )
+         DO 120 JC = 1, N
+            IF( ALPHAI( JC ).LT.ZERO )
+     $         GO TO 120
+            TEMP = ZERO
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 80 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+   80          CONTINUE
+            ELSE
+               DO 90 JR = 1, N
+                  TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+     $                   ABS( VR( JR, JC+1 ) ) )
+   90          CONTINUE
+            END IF
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 120
+            TEMP = ONE / TEMP
+            IF( ALPHAI( JC ).EQ.ZERO ) THEN
+               DO 100 JR = 1, N
+                  VR( JR, JC ) = VR( JR, JC )*TEMP
+  100          CONTINUE
+            ELSE
+               DO 110 JR = 1, N
+                  VR( JR, JC ) = VR( JR, JC )*TEMP
+                  VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+  110          CONTINUE
+            END IF
+  120    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ILASCL ) THEN
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+  130 CONTINUE
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of SGGEVX
+*
+      END
diff --git a/SRC/sggglm.f b/SRC/sggglm.f
new file mode 100644
index 00000000..5ffb2a43
--- /dev/null
+++ b/SRC/sggglm.f
@@ -0,0 +1,258 @@
+      SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, 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, P
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
+     $                   X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGGLM solves a general Gauss-Markov linear model (GLM) problem:
+*
+*          minimize || y ||_2   subject to   d = A*x + B*y
+*              x
+*
+*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
+*  given N-vector. It is assumed that M <= N <= M+P, and
+*
+*             rank(A) = M    and    rank( A B ) = N.
+*
+*  Under these assumptions, the constrained equation is always
+*  consistent, and there is a unique solution x and a minimal 2-norm
+*  solution y, which is obtained using a generalized QR factorization
+*  of the matrices (A, B) given by
+*
+*     A = Q*(R),   B = Q*T*Z.
+*           (0)
+*
+*  In particular, if matrix B is square nonsingular, then the problem
+*  GLM is equivalent to the following weighted linear least squares
+*  problem
+*
+*               minimize || inv(B)*(d-A*x) ||_2
+*                   x
+*
+*  where inv(B) denotes the inverse of B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B.  N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  0 <= M <= N.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= N-M.
+*
+*  A       (input/output) REAL array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the upper triangular part of the array A contains
+*          the M-by-M upper triangular matrix R.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) REAL array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, D is the left hand side of the GLM equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) REAL array, dimension (M)
+*  Y       (output) REAL array, dimension (P)
+*          On exit, X and Y are the solutions of the GLM problem.
+*
+*  WORK    (workspace/output) REAL 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+M+P).
+*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          SGEQRF, SGERQF, SORMQR and SORMRQ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the upper triangular factor R associated with A in the
+*                generalized QR factorization of the pair (A, B) is
+*                singular, so that rank(A) < M; the least squares
+*                solution could not be computed.
+*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal
+*                factor T associated with B in the generalized QR
+*                factorization of the pair (A, B) is singular, so that
+*                rank( A B ) < N; the least squares solution could not
+*                be computed.
+*
+*  ===================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
+     $                   NB4, NP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMV, SGGQRF, SORMQR, SORMRQ, STRTRS,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NP = MIN( N, P )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'SGEQRF', ' ', N, M, -1, -1 )
+            NB2 = ILAENV( 1, 'SGERQF', ' ', N, M, -1, -1 )
+            NB3 = ILAENV( 1, 'SORMQR', ' ', N, M, P, -1 )
+            NB4 = ILAENV( 1, 'SORMRQ', ' ', N, M, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = M + NP + MAX( N, P )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGGLM', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GQR factorization of matrices A and B:
+*
+*            Q'*A = ( R11 ) M,    Q'*B*Z' = ( T11   T12 ) M
+*                   (  0  ) N-M             (  0    T22 ) N-M
+*                      M                     M+P-N  N-M
+*
+*     where R11 and T22 are upper triangular, and Q and Z are
+*     orthogonal.
+*
+      CALL SGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
+     $             WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = WORK( M+NP+1 )
+*
+*     Update left-hand-side vector d = Q'*d = ( d1 ) M
+*                                             ( d2 ) N-M
+*
+      CALL SORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D,
+     $             MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+*     Solve T22*y2 = d2 for y2
+*
+      IF( N.GT.M ) THEN
+         CALL STRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
+     $                B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+         CALL SCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
+      END IF
+*
+*     Set y1 = 0
+*
+      DO 10 I = 1, M + P - N
+         Y( I ) = ZERO
+   10 CONTINUE
+*
+*     Update d1 = d1 - T12*y2
+*
+      CALL SGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB,
+     $            Y( M+P-N+1 ), 1, ONE, D, 1 )
+*
+*     Solve triangular system: R11*x = d1
+*
+      IF( M.GT.0 ) THEN
+         CALL STRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
+     $                D, M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Copy D to X
+*
+         CALL SCOPY( M, D, 1, X, 1 )
+      END IF
+*
+*     Backward transformation y = Z'*y
+*
+      CALL SORMRQ( 'Left', 'Transpose', P, 1, NP,
+     $             B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
+     $             MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+      RETURN
+*
+*     End of SGGGLM
+*
+      END
diff --git a/SRC/sgghrd.f b/SRC/sgghrd.f
new file mode 100644
index 00000000..db7c1e6d
--- /dev/null
+++ b/SRC/sgghrd.f
@@ -0,0 +1,264 @@
+      SUBROUTINE SGGHRD( 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 ..
+      REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGHRD 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 SGGHRD 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) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILQ, ILZ
+      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
+      REAL               C, S, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARTG, SLASET, SROT, 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( 'SGGHRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z if desired.
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL SLASET( '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 SLARTG( TEMP, A( JROW, JCOL ), C, S,
+     $                   A( JROW-1, JCOL ) )
+            A( JROW, JCOL ) = ZERO
+            CALL SROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
+     $                 A( JROW, JCOL+1 ), LDA, C, S )
+            CALL SROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
+     $                 B( JROW, JROW-1 ), LDB, C, S )
+            IF( ILQ )
+     $         CALL SROT( 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 SLARTG( TEMP, B( JROW, JROW-1 ), C, S,
+     $                   B( JROW, JROW ) )
+            B( JROW, JROW-1 ) = ZERO
+            CALL SROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
+            CALL SROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
+     $                 S )
+            IF( ILZ )
+     $         CALL SROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
+   30    CONTINUE
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of SGGHRD
+*
+      END
diff --git a/SRC/sgglse.f b/SRC/sgglse.f
new file mode 100644
index 00000000..c821782e
--- /dev/null
+++ b/SRC/sgglse.f
@@ -0,0 +1,266 @@
+      SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, 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, P
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), C( * ), D( * ),
+     $                   WORK( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGLSE solves the linear equality-constrained least squares (LSE)
+*  problem:
+*
+*          minimize || c - A*x ||_2   subject to   B*x = d
+*
+*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
+*  M-vector, and d is a given P-vector. It is assumed that
+*  P <= N <= M+P, and
+*
+*           rank(B) = P and  rank( (A) ) = N.
+*                                ( (B) )
+*
+*  These conditions ensure that the LSE problem has a unique solution,
+*  which is obtained using a generalized RQ factorization of the
+*  matrices (B, A) given by
+*
+*     B = (0 R)*Q,   A = Z*T*Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B. 0 <= P <= N <= M+P.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(M,N)-by-N upper trapezoidal matrix T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) REAL array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
+*          contains the P-by-P upper triangular matrix R.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  C       (input/output) REAL array, dimension (M)
+*          On entry, C contains the right hand side vector for the
+*          least squares part of the LSE problem.
+*          On exit, the residual sum of squares for the solution
+*          is given by the sum of squares of elements N-P+1 to M of
+*          vector C.
+*
+*  D       (input/output) REAL array, dimension (P)
+*          On entry, D contains the right hand side vector for the
+*          constrained equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) REAL array, dimension (N)
+*          On exit, X is the solution of the LSE problem.
+*
+*  WORK    (workspace/output) REAL 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+N+P).
+*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          SGEQRF, SGERQF, SORMQR and SORMRQ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the upper triangular factor R associated with B in the
+*                generalized RQ factorization of the pair (B, A) is
+*                singular, so that rank(B) < P; the least squares
+*                solution could not be computed.
+*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor
+*                T associated with A in the generalized RQ factorization
+*                of the pair (B, A) is singular, so that
+*                rank( (A) ) < N; the least squares solution could not
+*                    ( (B) )
+*                be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
+     $                   NB4, NR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SGGRQF, SORMQR, SORMRQ,
+     $                   STRMV, STRTRS, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+            NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+            NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, P, -1 )
+            NB4 = ILAENV( 1, 'SORMRQ', ' ', M, N, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = P + MN + MAX( M, N )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGLSE', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GRQ factorization of matrices B and A:
+*
+*            B*Q' = (  0  T12 ) P   Z'*A*Q' = ( R11 R12 ) N-P
+*                     N-P  P                  (  0  R22 ) M+P-N
+*                                               N-P  P
+*
+*     where T12 and R11 are upper triangular, and Q and Z are
+*     orthogonal.
+*
+      CALL SGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
+     $             WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      LOPT = WORK( P+MN+1 )
+*
+*     Update c = Z'*c = ( c1 ) N-P
+*                       ( c2 ) M+P-N
+*
+      CALL SORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ),
+     $             C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+*     Solve T12*x2 = d for x2
+*
+      IF( P.GT.0 ) THEN
+         CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
+     $                B( 1, N-P+1 ), LDB, D, P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+*        Put the solution in X
+*
+         CALL SCOPY( P, D, 1, X( N-P+1 ), 1 )
+*
+*        Update c1
+*
+         CALL SGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA,
+     $               D, 1, ONE, C, 1 )
+      END IF
+*
+*     Solve R11*x1 = c1 for x1
+*
+      IF( N.GT.P ) THEN
+         CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
+     $                A, LDA, C, N-P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Put the solution in X
+*
+         CALL SCOPY( N-P, C, 1, X, 1 )
+      END IF
+*
+*     Compute the residual vector:
+*
+      IF( M.LT.N ) THEN
+         NR = M + P - N
+         IF( NR.GT.0 )
+     $      CALL SGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ),
+     $                  LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
+      ELSE
+         NR = P
+      END IF
+      IF( NR.GT.0 ) THEN
+         CALL STRMV( 'Upper', 'No transpose', 'Non unit', NR,
+     $               A( N-P+1, N-P+1 ), LDA, D, 1 )
+         CALL SAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
+      END IF
+*
+*     Backward transformation x = Q'*x
+*
+      CALL SORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X,
+     $             N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+      RETURN
+*
+*     End of SGGLSE
+*
+      END
diff --git a/SRC/sggqrf.f b/SRC/sggqrf.f
new file mode 100644
index 00000000..7d2c523d
--- /dev/null
+++ b/SRC/sggqrf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGQRF computes a generalized QR factorization of an N-by-M matrix A
+*  and an N-by-P matrix B:
+*
+*              A = Q*R,        B = Q*T*Z,
+*
+*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+*  matrix, and R and T assume one of the forms:
+*
+*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
+*                  (  0  ) N-M                         N   M-N
+*                     M
+*
+*  where R11 is upper triangular, and
+*
+*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
+*                   P-N  N                           ( T21 ) P
+*                                                       P
+*
+*  where T12 or T21 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GQR factorization
+*  of A and B implicitly gives the QR factorization of inv(B)*A:
+*
+*               inv(B)*A = Z'*(inv(T)*R)
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  transpose of the matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B. N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
+*          upper triangular if N >= M); the elements below the diagonal,
+*          with the array TAUA, represent the orthogonal matrix Q as a
+*          product of min(N,M) elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAUA    (output) REAL array, dimension (min(N,M))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q (see Further Details).
+*
+*  B       (input/output) REAL array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)-th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T; the remaining
+*          elements, with the array TAUB, represent the orthogonal
+*          matrix Z as a product of elementary reflectors (see Further
+*          Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  TAUB    (output) REAL array, dimension (min(N,P))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Z (see Further Details).
+*
+*  WORK    (workspace/output) REAL 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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the QR factorization
+*          of an N-by-M matrix, NB2 is the optimal blocksize for the
+*          RQ factorization of an N-by-P matrix, and NB3 is the optimal
+*          blocksize for a call of SORMQR.
+*
+*          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(n,m).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taua * v * v'
+*
+*  where taua is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+*  and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine SORGQR.
+*  To use Q to update another matrix, use LAPACK subroutine SORMQR.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(n,p).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a real scalar, and v is a real vector with
+*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
+*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine SORGRQ.
+*  To use Z to update another matrix, use LAPACK subroutine SORMRQ.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGERQF, SORMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'SGEQRF', ' ', N, M, -1, -1 )
+      NB2 = ILAENV( 1, 'SGERQF', ' ', N, P, -1, -1 )
+      NB3 = ILAENV( 1, 'SORMQR', ' ', N, M, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     QR factorization of N-by-M matrix A: A = Q*R
+*
+      CALL SGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := Q'*B.
+*
+      CALL SORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
+     $             B, LDB, WORK, LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     RQ factorization of N-by-P matrix B: B = T*Z.
+*
+      CALL SGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of SGGQRF
+*
+      END
diff --git a/SRC/sggrqf.f b/SRC/sggrqf.f
new file mode 100644
index 00000000..e1217663
--- /dev/null
+++ b/SRC/sggrqf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGRQF computes a generalized RQ factorization of an M-by-N matrix A
+*  and a P-by-N matrix B:
+*
+*              A = R*Q,        B = Z*T*Q,
+*
+*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+*  matrix, and R and T assume one of the forms:
+*
+*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
+*                   N-M  M                           ( R21 ) N
+*                                                       N
+*
+*  where R12 or R21 is upper triangular, and
+*
+*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
+*                  (  0  ) P-N                         P   N-P
+*                     N
+*
+*  where T11 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GRQ factorization
+*  of A and B implicitly gives the RQ factorization of A*inv(B):
+*
+*               A*inv(B) = (R*inv(T))*Z'
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  transpose of the matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, if M <= N, the upper triangle of the subarray
+*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
+*          if M > N, the elements on and above the (M-N)-th subdiagonal
+*          contain the M-by-N upper trapezoidal matrix R; the remaining
+*          elements, with the array TAUA, represent the orthogonal
+*          matrix Q as a product of elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  TAUA    (output) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q (see Further Details).
+*
+*  B       (input/output) REAL array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
+*          upper triangular if P >= N); the elements below the diagonal,
+*          with the array TAUB, represent the orthogonal matrix Z as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TAUB    (output) REAL array, dimension (min(P,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Z (see Further Details).
+*
+*  WORK    (workspace/output) REAL 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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the RQ factorization
+*          of an M-by-N matrix, NB2 is the optimal blocksize for the
+*          QR factorization of a P-by-N matrix, and NB3 is the optimal
+*          blocksize for a call of SORMRQ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INF0= -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 - taua * v * v'
+*
+*  where taua is a real scalar, and v is a real vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine SORGRQ.
+*  To use Q to update another matrix, use LAPACK subroutine SORMRQ.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(p,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
+*  and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine SORGQR.
+*  To use Z to update another matrix, use LAPACK subroutine SORMQR.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQRF, SGERQF, SORMRQ, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV 
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'SGEQRF', ' ', P, N, -1, -1 )
+      NB3 = ILAENV( 1, 'SORMRQ', ' ', M, N, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P)*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGRQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     RQ factorization of M-by-N matrix A: A = R*Q
+*
+      CALL SGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := B*Q'
+*
+      CALL SORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ),
+     $             A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
+     $             LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     QR factorization of P-by-N matrix B: B = Z*T
+*
+      CALL SGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of SGGRQF
+*
+      END
diff --git a/SRC/sggsvd.f b/SRC/sggsvd.f
new file mode 100644
index 00000000..e3f042c3
--- /dev/null
+++ b/SRC/sggsvd.f
@@ -0,0 +1,335 @@
+      SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
+     $                   LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), Q( LDQ, * ), U( LDU, * ),
+     $                   V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGSVD computes the generalized singular value decomposition (GSVD)
+*  of an M-by-N real matrix A and P-by-N real matrix B:
+*
+*      U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )
+*
+*  where U, V and Q are orthogonal matrices, and Z' is the transpose
+*  of Z.  Let K+L = the effective numerical rank of the matrix (A',B')',
+*  then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
+*  D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
+*  following structures, respectively:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                    K  L
+*         D2 =   L ( 0  S )
+*              P-L ( 0  0 )
+*
+*                  N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 )
+*              L (  0    0   R22 )
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                    K M-K K+L-M
+*         D1 =   K ( I  0    0   )
+*              M-K ( 0  C    0   )
+*
+*                      K M-K K+L-M
+*         D2 =   M-K ( 0  S    0  )
+*              K+L-M ( 0  0    I  )
+*                P-L ( 0  0    0  )
+*
+*                     N-K-L  K   M-K  K+L-M
+*    ( 0 R ) =     K ( 0    R11  R12  R13  )
+*                M-K ( 0     0   R22  R23  )
+*              K+L-M ( 0     0    0   R33  )
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*    S = diag( BETA(K+1),  ... , BETA(M) ),
+*    C**2 + S**2 = I.
+*
+*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
+*    ( 0  R22 R23 )
+*    in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The routine computes C, S, R, and optionally the orthogonal
+*  transformation matrices U, V and Q.
+*
+*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
+*  A and B implicitly gives the SVD of A*inv(B):
+*                       A*inv(B) = U*(D1*inv(D2))*V'.
+*  If ( A',B')' has orthonormal columns, then the GSVD of A and B is
+*  also equal to the CS decomposition of A and B. Furthermore, the GSVD
+*  can be used to derive the solution of the eigenvalue problem:
+*                       A'*A x = lambda* B'*B x.
+*  In some literature, the GSVD of A and B is presented in the form
+*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )
+*  where U and V are orthogonal and X is nonsingular, D1 and D2 are
+*  ``diagonal''.  The former GSVD form can be converted to the latter
+*  form by taking the nonsingular matrix X as
+*
+*                       X = Q*( I   0    )
+*                             ( 0 inv(R) ).
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Orthogonal matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Orthogonal matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Orthogonal matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in the Purpose section.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular matrix R, or part of R.
+*          See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) REAL array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains the triangular matrix R if M-K-L < 0.
+*          See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  ALPHA   (output) REAL array, dimension (N)
+*  BETA    (output) REAL array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = C,
+*            BETA(K+1:K+L)  = S,
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
+*            BETA(K+1:M) =S, BETA(M+1:K+L) =1
+*          and
+*            ALPHA(K+L+1:N) = 0
+*            BETA(K+L+1:N)  = 0
+*
+*  U       (output) REAL array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) REAL array, dimension (LDV,P)
+*          If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) REAL array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) REAL array,
+*                      dimension (max(3*N,M,P)+N)
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (N)
+*          On exit, IWORK stores the sorting information. More
+*          precisely, the following loop will sort ALPHA
+*             for I = K+1, min(M,K+L)
+*                 swap ALPHA(I) and ALPHA(IWORK(I))
+*             endfor
+*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, the Jacobi-type procedure failed to
+*                converge.  For further details, see subroutine STGSJA.
+*
+*  Internal Parameters
+*  ===================
+*
+*  TOLA    REAL
+*  TOLB    REAL
+*          TOLA and TOLB are the thresholds to determine the effective
+*          rank of (A',B')'. Generally, they are set to
+*                   TOLA = MAX(M,N)*norm(A)*MACHEPS,
+*                   TOLB = MAX(P,N)*norm(B)*MACHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  Further Details
+*  ===============
+*
+*  2-96 Based on modifications by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            WANTQ, WANTU, WANTV
+      INTEGER            I, IBND, ISUB, J, NCYCLE
+      REAL               ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           LSAME, SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGGSVP, STGSJA, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGSVD', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Frobenius norm of matrices A and B
+*
+      ANORM = SLANGE( '1', M, N, A, LDA, WORK )
+      BNORM = SLANGE( '1', P, N, B, LDB, WORK )
+*
+*     Get machine precision and set up threshold for determining
+*     the effective numerical rank of the matrices A and B.
+*
+      ULP = SLAMCH( 'Precision' )
+      UNFL = SLAMCH( 'Safe Minimum' )
+      TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
+      TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
+*
+*     Preprocessing
+*
+      CALL SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
+     $             TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK,
+     $             WORK( N+1 ), INFO )
+*
+*     Compute the GSVD of two upper "triangular" matrices
+*
+      CALL STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB,
+     $             TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
+     $             WORK, NCYCLE, INFO )
+*
+*     Sort the singular values and store the pivot indices in IWORK
+*     Copy ALPHA to WORK, then sort ALPHA in WORK
+*
+      CALL SCOPY( N, ALPHA, 1, WORK, 1 )
+      IBND = MIN( L, M-K )
+      DO 20 I = 1, IBND
+*
+*        Scan for largest ALPHA(K+I)
+*
+         ISUB = I
+         SMAX = WORK( K+I )
+         DO 10 J = I + 1, IBND
+            TEMP = WORK( K+J )
+            IF( TEMP.GT.SMAX ) THEN
+               ISUB = J
+               SMAX = TEMP
+            END IF
+   10    CONTINUE
+         IF( ISUB.NE.I ) THEN
+            WORK( K+ISUB ) = WORK( K+I )
+            WORK( K+I ) = SMAX
+            IWORK( K+I ) = K + ISUB
+         ELSE
+            IWORK( K+I ) = K + I
+         END IF
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of SGGSVD
+*
+      END
diff --git a/SRC/sggsvp.f b/SRC/sggsvp.f
new file mode 100644
index 00000000..e1263d60
--- /dev/null
+++ b/SRC/sggsvp.f
@@ -0,0 +1,393 @@
+      SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
+     $                   TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,
+     $                   IWORK, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+      REAL               TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGGSVP computes orthogonal matrices U, V and Q such that
+*
+*                   N-K-L  K    L
+*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
+*                L ( 0     0   A23 )
+*            M-K-L ( 0     0    0  )
+*
+*                   N-K-L  K    L
+*          =     K ( 0    A12  A13 )  if M-K-L < 0;
+*              M-K ( 0     0   A23 )
+*
+*                 N-K-L  K    L
+*   V'*B*Q =   L ( 0     0   B13 )
+*            P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
+*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the
+*  transpose of Z.
+*
+*  This decomposition is the preprocessing step for computing the
+*  Generalized Singular Value Decomposition (GSVD), see subroutine
+*  SGGSVD.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Orthogonal matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Orthogonal matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Orthogonal matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular (or trapezoidal) matrix
+*          described in the Purpose section.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) REAL array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains the triangular matrix described in
+*          the Purpose section.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) REAL
+*  TOLB    (input) REAL
+*          TOLA and TOLB are the thresholds to determine the effective
+*          numerical rank of matrix B and a subblock of A. Generally,
+*          they are set to
+*             TOLA = MAX(M,N)*norm(A)*MACHEPS,
+*             TOLB = MAX(P,N)*norm(B)*MACHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in Purpose.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  U       (output) REAL array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the orthogonal matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) REAL array, dimension (LDV,M)
+*          If JOBV = 'V', V contains the orthogonal matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) REAL array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the orthogonal matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  TAU     (workspace) REAL array, dimension (N)
+*
+*  WORK    (workspace) REAL array, dimension (max(3*N,M,P))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*
+*  Further Details
+*  ===============
+*
+*  The subroutine uses LAPACK subroutine SGEQPF for the QR factorization
+*  with column pivoting to detect the effective numerical rank of the
+*  a matrix. It may be replaced by a better rank determination strategy.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORWRD, WANTQ, WANTU, WANTV
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEQPF, SGEQR2, SGERQ2, SLACPY, SLAPMT, SLASET,
+     $                   SORG2R, SORM2R, SORMR2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+      FORWRD = .TRUE.
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -10
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGGSVP', -INFO )
+         RETURN
+      END IF
+*
+*     QR with column pivoting of B: B*P = V*( S11 S12 )
+*                                           (  0   0  )
+*
+      DO 10 I = 1, N
+         IWORK( I ) = 0
+   10 CONTINUE
+      CALL SGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
+*
+*     Update A := A*P
+*
+      CALL SLAPMT( FORWRD, M, N, A, LDA, IWORK )
+*
+*     Determine the effective rank of matrix B.
+*
+      L = 0
+      DO 20 I = 1, MIN( P, N )
+         IF( ABS( B( I, I ) ).GT.TOLB )
+     $      L = L + 1
+   20 CONTINUE
+*
+      IF( WANTV ) THEN
+*
+*        Copy the details of V, and form V.
+*
+         CALL SLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
+         IF( P.GT.1 )
+     $      CALL SLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
+     $                   LDV )
+         CALL SORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
+      END IF
+*
+*     Clean up B
+*
+      DO 40 J = 1, L - 1
+         DO 30 I = J + 1, L
+            B( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      IF( P.GT.L )
+     $   CALL SLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
+*
+      IF( WANTQ ) THEN
+*
+*        Set Q = I and Update Q := Q*P
+*
+         CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+         CALL SLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
+      END IF
+*
+      IF( P.GE.L .AND. N.NE.L ) THEN
+*
+*        RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
+*
+         CALL SGERQ2( L, N, B, LDB, TAU, WORK, INFO )
+*
+*        Update A := A*Z'
+*
+         CALL SORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A,
+     $                LDA, WORK, INFO )
+*
+         IF( WANTQ ) THEN
+*
+*           Update Q := Q*Z'
+*
+            CALL SORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
+     $                   LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up B
+*
+         CALL SLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
+         DO 60 J = N - L + 1, N
+            DO 50 I = J - N + L + 1, L
+               B( I, J ) = ZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+      END IF
+*
+*     Let              N-L     L
+*                A = ( A11    A12 ) M,
+*
+*     then the following does the complete QR decomposition of A11:
+*
+*              A11 = U*(  0  T12 )*P1'
+*                      (  0   0  )
+*
+      DO 70 I = 1, N - L
+         IWORK( I ) = 0
+   70 CONTINUE
+      CALL SGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
+*
+*     Determine the effective rank of A11
+*
+      K = 0
+      DO 80 I = 1, MIN( M, N-L )
+         IF( ABS( A( I, I ) ).GT.TOLA )
+     $      K = K + 1
+   80 CONTINUE
+*
+*     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
+*
+      CALL SORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
+     $             TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
+*
+      IF( WANTU ) THEN
+*
+*        Copy the details of U, and form U
+*
+         CALL SLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
+         IF( M.GT.1 )
+     $      CALL SLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
+     $                   LDU )
+         CALL SORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
+      END IF
+*
+      IF( WANTQ ) THEN
+*
+*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1
+*
+         CALL SLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
+      END IF
+*
+*     Clean up A: set the strictly lower triangular part of
+*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
+*
+      DO 100 J = 1, K - 1
+         DO 90 I = J + 1, K
+            A( I, J ) = ZERO
+   90    CONTINUE
+  100 CONTINUE
+      IF( M.GT.K )
+     $   CALL SLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
+*
+      IF( N-L.GT.K ) THEN
+*
+*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
+*
+         CALL SGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
+*
+         IF( WANTQ ) THEN
+*
+*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
+*
+            CALL SORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU,
+     $                   Q, LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up A
+*
+         CALL SLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
+         DO 120 J = N - L - K + 1, N - L
+            DO 110 I = J - N + L + K + 1, K
+               A( I, J ) = ZERO
+  110       CONTINUE
+  120    CONTINUE
+*
+      END IF
+*
+      IF( M.GT.K ) THEN
+*
+*        QR factorization of A( K+1:M,N-L+1:N )
+*
+         CALL SGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
+*
+         IF( WANTU ) THEN
+*
+*           Update U(:,K+1:M) := U(:,K+1:M)*U1
+*
+            CALL SORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
+     $                   A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
+     $                   WORK, INFO )
+         END IF
+*
+*        Clean up
+*
+         DO 140 J = N - L + 1, N
+            DO 130 I = J - N + K + L + 1, M
+               A( I, J ) = ZERO
+  130       CONTINUE
+  140    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of SGGSVP
+*
+      END
diff --git a/SRC/sgtcon.f b/SRC/sgtcon.f
new file mode 100644
index 00000000..91911340
--- /dev/null
+++ b/SRC/sgtcon.f
@@ -0,0 +1,170 @@
+      SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTCON estimates the reciprocal of the condition number of a real
+*  tridiagonal matrix A using the LU factorization as computed by
+*  SGTTRF.
+*
+*  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
+*  =========
+*
+*  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.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by SGTTRF.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) REAL array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  ANORM   (input) REAL
+*          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) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ONENRM
+      INTEGER            I, KASE, KASE1
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGTTRS, SLACN2, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is non-zero.
+*
+      DO 10 I = 1, N
+         IF( D( I ).EQ.ZERO )
+     $      RETURN
+   10 CONTINUE
+*
+      AINVNM = ZERO
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KASE = 0
+   20 CONTINUE
+      CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(U)*inv(L).
+*
+            CALL SGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
+     $                   WORK, N, INFO )
+         ELSE
+*
+*           Multiply by inv(L')*inv(U').
+*
+            CALL SGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK,
+     $                   N, INFO )
+         END IF
+         GO TO 20
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of SGTCON
+*
+      END
diff --git a/SRC/sgtrfs.f b/SRC/sgtrfs.f
new file mode 100644
index 00000000..1db55eb3
--- /dev/null
+++ b/SRC/sgtrfs.f
@@ -0,0 +1,361 @@
+      SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
+     $                   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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is tridiagonal, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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 matrix B.  NRHS >= 0.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) REAL array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input) REAL array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by SGTTRF.
+*
+*  DF      (input) REAL array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DUF     (input) REAL array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) REAL array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SGTTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGTTRS, SLACN2, SLAGTM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -15
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'T'
+      ELSE
+         TRANSN = 'T'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 110 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
+     $                WORK( N+1 ), N )
+*
+*        Compute abs(op(A))*abs(x) + abs(b) for use in the backward
+*        error bound.
+*
+         IF( NOTRAN ) THEN
+            IF( N.EQ.1 ) THEN
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+            ELSE
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+     $                     ABS( DU( 1 )*X( 2, J ) )
+               DO 30 I = 2, N - 1
+                  WORK( I ) = ABS( B( I, J ) ) +
+     $                        ABS( DL( I-1 )*X( I-1, J ) ) +
+     $                        ABS( D( I )*X( I, J ) ) +
+     $                        ABS( DU( I )*X( I+1, J ) )
+   30          CONTINUE
+               WORK( N ) = ABS( B( N, J ) ) +
+     $                     ABS( DL( N-1 )*X( N-1, J ) ) +
+     $                     ABS( D( N )*X( N, J ) )
+            END IF
+         ELSE
+            IF( N.EQ.1 ) THEN
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+            ELSE
+               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+     $                     ABS( DL( 1 )*X( 2, J ) )
+               DO 40 I = 2, N - 1
+                  WORK( I ) = ABS( B( I, J ) ) +
+     $                        ABS( DU( I-1 )*X( I-1, J ) ) +
+     $                        ABS( D( I )*X( I, J ) ) +
+     $                        ABS( DL( I )*X( I+1, J ) )
+   40          CONTINUE
+               WORK( N ) = ABS( B( N, J ) ) +
+     $                     ABS( DU( N-1 )*X( N-1, J ) ) +
+     $                     ABS( D( N )*X( N, J ) )
+            END IF
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 50 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   50    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,
+     $                   WORK( N+1 ), N, INFO )
+            CALL SAXPY( 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 SLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 60 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   60    CONTINUE
+*
+         KASE = 0
+   70    CONTINUE
+         CALL SLACN2( 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 SGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+               DO 80 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+   80          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 90 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+   90          CONTINUE
+               CALL SGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
+     $                      WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 70
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 100 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  100    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of SGTRFS
+*
+      END
diff --git a/SRC/sgtsv.f b/SRC/sgtsv.f
new file mode 100644
index 00000000..d43066b1
--- /dev/null
+++ b/SRC/sgtsv.f
@@ -0,0 +1,262 @@
+      SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTSV  solves the equation
+*
+*     A*X = B,
+*
+*  where A is an n by n tridiagonal matrix, by Gaussian elimination with
+*  partial pivoting.
+*
+*  Note that the equation  A'*X = B  may be solved by interchanging the
+*  order of the arguments DU and DL.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  DL      (input/output) REAL array, dimension (N-1)
+*          On entry, DL must contain the (n-1) sub-diagonal elements of
+*          A.
+*
+*          On exit, DL is overwritten by the (n-2) elements of the
+*          second super-diagonal of the upper triangular matrix U from
+*          the LU factorization of A, in DL(1), ..., DL(n-2).
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*
+*          On exit, D is overwritten by the n diagonal elements of U.
+*
+*  DU      (input/output) REAL array, dimension (N-1)
+*          On entry, DU must contain the (n-1) super-diagonal elements
+*          of A.
+*
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          super-diagonal of U.
+*
+*  B       (input/output) REAL 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, and the solution
+*               has not been computed.  The factorization has not been
+*               completed unless i = N.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               FACT, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGTSV ', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( NRHS.EQ.1 ) THEN
+         DO 10 I = 1, N - 2
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+*              No row interchange required
+*
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+               DL( I ) = ZERO
+            ELSE
+*
+*              Interchange rows I and I+1
+*
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DL( I ) = DU( I+1 )
+               DU( I+1 ) = -FACT*DL( I )
+               DU( I ) = TEMP
+               TEMP = B( I, 1 )
+               B( I, 1 ) = B( I+1, 1 )
+               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+            END IF
+   10    CONTINUE
+         IF( N.GT.1 ) THEN
+            I = N - 1
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+            ELSE
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DU( I ) = TEMP
+               TEMP = B( I, 1 )
+               B( I, 1 ) = B( I+1, 1 )
+               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+            END IF
+         END IF
+         IF( D( N ).EQ.ZERO ) THEN
+            INFO = N
+            RETURN
+         END IF
+      ELSE
+         DO 40 I = 1, N - 2
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+*              No row interchange required
+*
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  DO 20 J = 1, NRHS
+                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+   20             CONTINUE
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+               DL( I ) = ZERO
+            ELSE
+*
+*              Interchange rows I and I+1
+*
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DL( I ) = DU( I+1 )
+               DU( I+1 ) = -FACT*DL( I )
+               DU( I ) = TEMP
+               DO 30 J = 1, NRHS
+                  TEMP = B( I, J )
+                  B( I, J ) = B( I+1, J )
+                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
+   30          CONTINUE
+            END IF
+   40    CONTINUE
+         IF( N.GT.1 ) THEN
+            I = N - 1
+            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+               IF( D( I ).NE.ZERO ) THEN
+                  FACT = DL( I ) / D( I )
+                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
+                  DO 50 J = 1, NRHS
+                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+   50             CONTINUE
+               ELSE
+                  INFO = I
+                  RETURN
+               END IF
+            ELSE
+               FACT = D( I ) / DL( I )
+               D( I ) = DL( I )
+               TEMP = D( I+1 )
+               D( I+1 ) = DU( I ) - FACT*TEMP
+               DU( I ) = TEMP
+               DO 60 J = 1, NRHS
+                  TEMP = B( I, J )
+                  B( I, J ) = B( I+1, J )
+                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
+   60          CONTINUE
+            END IF
+         END IF
+         IF( D( N ).EQ.ZERO ) THEN
+            INFO = N
+            RETURN
+         END IF
+      END IF
+*
+*     Back solve with the matrix U from the factorization.
+*
+      IF( NRHS.LE.2 ) THEN
+         J = 1
+   70    CONTINUE
+         B( N, J ) = B( N, J ) / D( N )
+         IF( N.GT.1 )
+     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
+         DO 80 I = N - 2, 1, -1
+            B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+     $                  B( I+2, J ) ) / D( I )
+   80    CONTINUE
+         IF( J.LT.NRHS ) THEN
+            J = J + 1
+            GO TO 70
+         END IF
+      ELSE
+         DO 100 J = 1, NRHS
+            B( N, J ) = B( N, J ) / D( N )
+            IF( N.GT.1 )
+     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                       D( N-1 )
+            DO 90 I = N - 2, 1, -1
+               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+     $                     B( I+2, J ) ) / D( I )
+   90       CONTINUE
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SGTSV
+*
+      END
diff --git a/SRC/sgtsvx.f b/SRC/sgtsvx.f
new file mode 100644
index 00000000..61e4b48b
--- /dev/null
+++ b/SRC/sgtsvx.f
@@ -0,0 +1,291 @@
+      SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
+     $                   DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTSVX uses the LU factorization to compute the solution to a real
+*  system of linear equations A * X = B or A**T * X = B,
+*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A
+*     as A = L * U, where L is a product of permutation and unit lower
+*     bidiagonal matrices and U is upper triangular with nonzeros in
+*     only the main diagonal and first two superdiagonals.
+*
+*  2. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored
+*                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
+*                  will not be modified.
+*          = 'N':  The matrix will be copied to DLF, DF, and DUF
+*                  and factored.
+*
+*  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 matrix B.  NRHS >= 0.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of A.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input or output) REAL array, dimension (N-1)
+*          If FACT = 'F', then DLF is an input argument and on entry
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A as computed by SGTTRF.
+*
+*          If FACT = 'N', then DLF is an output argument and on exit
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A.
+*
+*  DF      (input or output) REAL array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*  DUF     (input or output) REAL array, dimension (N-1)
+*          If FACT = 'F', then DUF is an input argument and on entry
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*          If FACT = 'N', then DUF is an output argument and on exit
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input or output) REAL array, dimension (N-2)
+*          If FACT = 'F', then DU2 is an input argument and on entry
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*          If FACT = 'N', then DU2 is an output argument and on exit
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*  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 LU factorization of A as
+*          computed by SGTTRF.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the LU factorization of A;
+*          row i of the matrix was interchanged with row IPIV(i).
+*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
+*          a row interchange was not required.
+*
+*  B       (input) REAL array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  U(i,i) is exactly zero.  The factorization
+*                       has not been completed unless i = N, but the
+*                       factor U is exactly singular, so the solution
+*                       and error bounds could not be computed.
+*                       RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT, NOTRAN
+      CHARACTER          NORM
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANGT
+      EXTERNAL           LSAME, SLAMCH, SLANGT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGTCON, SGTRFS, SGTTRF, SGTTRS, SLACPY,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the LU factorization of A.
+*
+         CALL SCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 ) THEN
+            CALL SCOPY( N-1, DL, 1, DLF, 1 )
+            CALL SCOPY( N-1, DU, 1, DUF, 1 )
+         END IF
+         CALL SGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = SLANGT( NORM, N, DL, D, DU )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
+     $             IWORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of SGTSVX
+*
+      END
diff --git a/SRC/sgttrf.f b/SRC/sgttrf.f
new file mode 100644
index 00000000..9ee59bcd
--- /dev/null
+++ b/SRC/sgttrf.f
@@ -0,0 +1,168 @@
+      SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, 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 ..
+      INTEGER            IPIV( * )
+      REAL               D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTTRF computes an LU factorization of a real tridiagonal matrix A
+*  using elimination with partial pivoting and row interchanges.
+*
+*  The factorization has the form
+*     A = L * U
+*  where L is a product of permutation and unit lower bidiagonal
+*  matrices and U is upper triangular with nonzeros in only the main
+*  diagonal and first two superdiagonals.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  DL      (input/output) REAL array, dimension (N-1)
+*          On entry, DL must contain the (n-1) sub-diagonal elements of
+*          A.
+*
+*          On exit, DL is overwritten by the (n-1) multipliers that
+*          define the matrix L from the LU factorization of A.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*
+*          On exit, D is overwritten by the n diagonal elements of the
+*          upper triangular matrix U from the LU factorization of A.
+*
+*  DU      (input/output) REAL array, dimension (N-1)
+*          On entry, DU must contain the (n-1) super-diagonal elements
+*          of A.
+*
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          super-diagonal of U.
+*
+*  DU2     (output) REAL array, dimension (N-2)
+*          On exit, DU2 is overwritten by the (n-2) elements of the
+*          second super-diagonal of U.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               FACT, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'SGTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize IPIV(i) = i and DU2(I) = 0
+*
+      DO 10 I = 1, N
+         IPIV( I ) = I
+   10 CONTINUE
+      DO 20 I = 1, N - 2
+         DU2( I ) = ZERO
+   20 CONTINUE
+*
+      DO 30 I = 1, N - 2
+         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+*           No row interchange required, eliminate DL(I)
+*
+            IF( D( I ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+*
+*           Interchange rows I and I+1, eliminate DL(I)
+*
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            DU2( I ) = DU( I+1 )
+            DU( I+1 ) = -FACT*DU( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+   30 CONTINUE
+      IF( N.GT.1 ) THEN
+         I = N - 1
+         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+            IF( D( I ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+      END IF
+*
+*     Check for a zero on the diagonal of U.
+*
+      DO 40 I = 1, N
+         IF( D( I ).EQ.ZERO ) THEN
+            INFO = I
+            GO TO 50
+         END IF
+   40 CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of SGTTRF
+*
+      END
diff --git a/SRC/sgttrs.f b/SRC/sgttrs.f
new file mode 100644
index 00000000..e45c487d
--- /dev/null
+++ b/SRC/sgttrs.f
@@ -0,0 +1,140 @@
+      SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTTRS solves one of the systems of equations
+*     A*X = B  or  A'*X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by SGTTRF.
+*
+*  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.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) REAL array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors 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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            ITRANS, J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGTTS2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
+      IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
+     $    't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SGTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Decode TRANS
+*
+      IF( NOTRAN ) THEN
+         ITRANS = 0
+      ELSE
+         ITRANS = 1
+      END IF
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'SGTTRS', TRANS, N, NRHS, -1, -1 ) )
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL SGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
+     $                   LDB )
+   10    CONTINUE
+      END IF
+*
+*     End of SGTTRS
+*
+      END
diff --git a/SRC/sgtts2.f b/SRC/sgtts2.f
new file mode 100644
index 00000000..95448fdb
--- /dev/null
+++ b/SRC/sgtts2.f
@@ -0,0 +1,196 @@
+      SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ITRANS, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SGTTS2 solves one of the systems of equations
+*     A*X = B  or  A'*X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by SGTTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITRANS  (input) INTEGER
+*          Specifies the form of the system of equations.
+*          = 0:  A * X = B  (No transpose)
+*          = 1:  A'* X = B  (Transpose)
+*          = 2:  A'* X = B  (Conjugate transpose = Transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) REAL array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IP, J
+      REAL               TEMP
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( ITRANS.EQ.0 ) THEN
+*
+*        Solve A*X = B using the LU factorization of A,
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+   10       CONTINUE
+*
+*           Solve L*x = b.
+*
+            DO 20 I = 1, N - 1
+               IP = IPIV( I )
+               TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
+               B( I, J ) = B( IP, J )
+               B( I+1, J ) = TEMP
+   20       CONTINUE
+*
+*           Solve U*x = b.
+*
+            B( N, J ) = B( N, J ) / D( N )
+            IF( N.GT.1 )
+     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                       D( N-1 )
+            DO 30 I = N - 2, 1, -1
+               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                     B( I+2, J ) ) / D( I )
+   30       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 10
+            END IF
+         ELSE
+            DO 60 J = 1, NRHS
+*
+*              Solve L*x = b.
+*
+               DO 40 I = 1, N - 1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+                  ELSE
+                     TEMP = B( I, J )
+                     B( I, J ) = B( I+1, J )
+                     B( I+1, J ) = TEMP - DL( I )*B( I, J )
+                  END IF
+   40          CONTINUE
+*
+*              Solve U*x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               IF( N.GT.1 )
+     $            B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                          D( N-1 )
+               DO 50 I = N - 2, 1, -1
+                  B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                        B( I+2, J ) ) / D( I )
+   50          CONTINUE
+   60       CONTINUE
+         END IF
+      ELSE
+*
+*        Solve A' * X = B.
+*
+         IF( NRHS.LE.1 ) THEN
+*
+*           Solve U'*x = b.
+*
+            J = 1
+   70       CONTINUE
+            B( 1, J ) = B( 1, J ) / D( 1 )
+            IF( N.GT.1 )
+     $         B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+            DO 80 I = 3, N
+               B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
+     $                     B( I-2, J ) ) / D( I )
+   80       CONTINUE
+*
+*           Solve L'*x = b.
+*
+            DO 90 I = N - 1, 1, -1
+               IP = IPIV( I )
+               TEMP = B( I, J ) - DL( I )*B( I+1, J )
+               B( I, J ) = B( IP, J )
+               B( IP, J ) = TEMP
+   90       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 70
+            END IF
+*
+         ELSE
+            DO 120 J = 1, NRHS
+*
+*              Solve U'*x = b.
+*
+               B( 1, J ) = B( 1, J ) / D( 1 )
+               IF( N.GT.1 )
+     $            B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+               DO 100 I = 3, N
+                  B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
+     $                        DU2( I-2 )*B( I-2, J ) ) / D( I )
+  100          CONTINUE
+               DO 110 I = N - 1, 1, -1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+                  ELSE
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+                     B( I, J ) = TEMP
+                  END IF
+  110          CONTINUE
+  120       CONTINUE
+         END IF
+      END IF
+*
+*     End of SGTTS2
+*
+      END
diff --git a/SRC/shgeqz.f b/SRC/shgeqz.f
new file mode 100644
index 00000000..2f02b6d8
--- /dev/null
+++ b/SRC/shgeqz.f
@@ -0,0 +1,1243 @@
+      SUBROUTINE SHGEQZ( 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 ..
+      REAL               ALPHAI( * ), ALPHAR( * ), BETA( * ),
+     $                   H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SHGEQZ 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 SGGHRD.
+*
+*  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 SGGHRD 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) REAL 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) REAL 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) REAL array, dimension (N)
+*          The real parts of each scalar alpha defining an eigenvalue
+*          of GNEP.
+*
+*  ALPHAI  (output) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 )
+      REAL               HALF, ZERO, ONE, SAFETY
+      PARAMETER          ( HALF = 0.5E+0, ZERO = 0.0E+0, ONE = 1.0E+0,
+     $                   SAFETY = 1.0E+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
+      REAL               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 ..
+      REAL               V( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANHS, SLAPY2, SLAPY3
+      EXTERNAL           LSAME, SLAMCH, SLANHS, SLAPY2, SLAPY3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAG2, SLARFG, SLARTG, SLASET, SLASV2, SROT,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, 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( 'SHGEQZ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = REAL( 1 )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Machine Constants
+*
+      IN = IHI + 1 - ILO
+      SAFMIN = SLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
+      ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK )
+      BNORM = SLANHS( '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 SLARTG( TEMP, H( JCH+1, JCH ), C, S,
+     $                            H( JCH, JCH ) )
+                     H( JCH+1, JCH ) = ZERO
+                     CALL SROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
+     $                          H( JCH+1, JCH+1 ), LDH, C, S )
+                     CALL SROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
+     $                          T( JCH+1, JCH+1 ), LDT, C, S )
+                     IF( ILQ )
+     $                  CALL SROT( 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 SLARTG( TEMP, T( JCH+1, JCH+1 ), C, S,
+     $                            T( JCH, JCH+1 ) )
+                     T( JCH+1, JCH+1 ) = ZERO
+                     IF( JCH.LT.ILASTM-1 )
+     $                  CALL SROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
+     $                             T( JCH+1, JCH+2 ), LDT, C, S )
+                     CALL SROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
+     $                          H( JCH+1, JCH-1 ), LDH, C, S )
+                     IF( ILQ )
+     $                  CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, S )
+                     TEMP = H( JCH+1, JCH )
+                     CALL SLARTG( TEMP, H( JCH+1, JCH-1 ), C, S,
+     $                            H( JCH+1, JCH ) )
+                     H( JCH+1, JCH-1 ) = ZERO
+                     CALL SROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
+     $                          H( IFRSTM, JCH-1 ), 1, C, S )
+                     CALL SROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
+     $                          T( IFRSTM, JCH-1 ), 1, C, S )
+                     IF( ILZ )
+     $                  CALL SROT( 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 SLARTG( TEMP, H( ILAST, ILAST-1 ), C, S,
+     $                H( ILAST, ILAST ) )
+         H( ILAST, ILAST-1 ) = ZERO
+         CALL SROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
+     $              H( IFRSTM, ILAST-1 ), 1, C, S )
+         CALL SROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
+     $              T( IFRSTM, ILAST-1 ), 1, C, S )
+         IF( ILZ )
+     $      CALL SROT( 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( ( REAL( 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*REAL( 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 SLAG2 is the Wilkinson shift (AEP p.512),
+*
+            CALL SLAG2( 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 SLARTG( TEMP, TEMP2, C, S, TEMPR )
+*
+*        Sweep
+*
+         DO 190 J = ISTART, ILAST - 1
+            IF( J.GT.ISTART ) THEN
+               TEMP = H( J, J-1 )
+               CALL SLARTG( 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 SLARTG( 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 SLASV2( 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 SROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH,
+     $                 H( ILAST, ILAST-1 ), LDH, CL, SL )
+            CALL SROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1,
+     $                 H( IFRSTM, ILAST ), 1, CR, SR )
+*
+            IF( ILAST.LT.ILASTM )
+     $         CALL SROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT,
+     $                    T( ILAST, ILAST+1 ), LDH, CL, SL )
+            IF( IFRSTM.LT.ILAST-1 )
+     $         CALL SROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1,
+     $                    T( IFRSTM, ILAST ), 1, CR, SR )
+*
+            IF( ILQ )
+     $         CALL SROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL,
+     $                    SL )
+            IF( ILZ )
+     $         CALL SROT( 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 SLAG2( 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 = SLAPY3( C12, C11R, C11I )
+               CZ = C12 / T1
+               SZR = -C11R / T1
+               SZI = -C11I / T1
+            ELSE
+               CZ = SLAPY2( C22R, C22I )
+               IF( CZ.LE.SAFMIN ) THEN
+                  CZ = ZERO
+                  SZR = ONE
+                  SZI = ZERO
+               ELSE
+                  TEMPR = C22R / CZ
+                  TEMPI = C22I / CZ
+                  T1 = SLAPY2( 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 = SLAPY2( 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 = SLAPY3( 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 = SLAPY2( B1R, B1I )
+            B2R = CQ*CZ*B22 + TEMPR*B11
+            B2I = -TEMPI*B11
+            B2A = SLAPY2( 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 SLARFG( 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 SLARFG( 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 SLAGBC 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 SLARTG( 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 SLARTG( 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 ) = REAL( N )
+      RETURN
+*
+*     End of SHGEQZ
+*
+      END
diff --git a/SRC/shsein.f b/SRC/shsein.f
new file mode 100644
index 00000000..a2f79783
--- /dev/null
+++ b/SRC/shsein.f
@@ -0,0 +1,411 @@
+      SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
+     $                   VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
+     $                   IFAILR, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EIGSRC, INITV, SIDE
+      INTEGER            INFO, LDH, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IFAILL( * ), IFAILR( * )
+      REAL               H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WI( * ), WORK( * ), WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SHSEIN uses inverse iteration to find specified right and/or left
+*  eigenvectors of a real upper Hessenberg matrix H.
+*
+*  The right eigenvector x and the left eigenvector y of the matrix H
+*  corresponding to an eigenvalue w are defined by:
+*
+*               H * x = w * x,     y**h * H = w * y**h
+*
+*  where y**h denotes the conjugate transpose of the vector y.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R': compute right eigenvectors only;
+*          = 'L': compute left eigenvectors only;
+*          = 'B': compute both right and left eigenvectors.
+*
+*  EIGSRC  (input) CHARACTER*1
+*          Specifies the source of eigenvalues supplied in (WR,WI):
+*          = 'Q': the eigenvalues were found using SHSEQR; thus, if
+*                 H has zero subdiagonal elements, and so is
+*                 block-triangular, then the j-th eigenvalue can be
+*                 assumed to be an eigenvalue of the block containing
+*                 the j-th row/column.  This property allows SHSEIN to
+*                 perform inverse iteration on just one diagonal block.
+*          = 'N': no assumptions are made on the correspondence
+*                 between eigenvalues and diagonal blocks.  In this
+*                 case, SHSEIN must always perform inverse iteration
+*                 using the whole matrix H.
+*
+*  INITV   (input) CHARACTER*1
+*          = 'N': no initial vectors are supplied;
+*          = 'U': user-supplied initial vectors are stored in the arrays
+*                 VL and/or VR.
+*
+*  SELECT  (input/output) LOGICAL array, dimension (N)
+*          Specifies the eigenvectors to be computed. To select the
+*          real eigenvector corresponding to a real eigenvalue WR(j),
+*          SELECT(j) must be set to .TRUE.. To select the complex
+*          eigenvector corresponding to a complex eigenvalue
+*          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
+*          either SELECT(j) or SELECT(j+1) or both must be set to
+*          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
+*          .FALSE..
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) REAL array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  WR      (input/output) REAL array, dimension (N)
+*  WI      (input) REAL array, dimension (N)
+*          On entry, the real and imaginary parts of the eigenvalues of
+*          H; a complex conjugate pair of eigenvalues must be stored in
+*          consecutive elements of WR and WI.
+*          On exit, WR may have been altered since close eigenvalues
+*          are perturbed slightly in searching for independent
+*          eigenvectors.
+*
+*  VL      (input/output) REAL array, dimension (LDVL,MM)
+*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
+*          contain starting vectors for the inverse iteration for the
+*          left eigenvectors; the starting vector for each eigenvector
+*          must be in the same column(s) in which the eigenvector will
+*          be stored.
+*          On exit, if SIDE = 'L' or 'B', the left eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VL, in the same order as their eigenvalues. A
+*          complex eigenvector corresponding to a complex eigenvalue is
+*          stored in two consecutive columns, the first holding the real
+*          part and the second the imaginary part.
+*          If SIDE = 'R', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
+*
+*  VR      (input/output) REAL array, dimension (LDVR,MM)
+*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
+*          contain starting vectors for the inverse iteration for the
+*          right eigenvectors; the starting vector for each eigenvector
+*          must be in the same column(s) in which the eigenvector will
+*          be stored.
+*          On exit, if SIDE = 'R' or 'B', the right eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VR, in the same order as their eigenvalues. A
+*          complex eigenvector corresponding to a complex eigenvalue is
+*          stored in two consecutive columns, the first holding the real
+*          part and the second the imaginary part.
+*          If SIDE = 'L', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
+*
+*  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 required to
+*          store the eigenvectors; each selected real eigenvector
+*          occupies one column and each selected complex eigenvector
+*          occupies two columns.
+*
+*  WORK    (workspace) REAL array, dimension ((N+2)*N)
+*
+*  IFAILL  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
+*          eigenvector in the i-th column of VL (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
+*          eigenvector converged satisfactorily. If the i-th and (i+1)th
+*          columns of VL hold a complex eigenvector, then IFAILL(i) and
+*          IFAILL(i+1) are set to the same value.
+*          If SIDE = 'R', IFAILL is not referenced.
+*
+*  IFAILR  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
+*          eigenvector in the i-th column of VR (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
+*          eigenvector converged satisfactorily. If the i-th and (i+1)th
+*          columns of VR hold a complex eigenvector, then IFAILR(i) and
+*          IFAILR(i+1) are set to the same value.
+*          If SIDE = 'L', IFAILR is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, i is the number of eigenvectors which
+*                failed to converge; see IFAILL and IFAILR for further
+*                details.
+*
+*  Further Details
+*  ===============
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
+      INTEGER            I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
+      REAL               BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
+     $                   WKR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANHS
+      EXTERNAL           LSAME, SLAMCH, SLANHS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAEIN, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters.
+*
+      BOTHV = LSAME( SIDE, 'B' )
+      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+      FROMQR = LSAME( EIGSRC, 'Q' )
+*
+      NOINIT = LSAME( INITV, 'N' )
+*
+*     Set M to the number of columns required to store the selected
+*     eigenvectors, and standardize the array SELECT.
+*
+      M = 0
+      PAIR = .FALSE.
+      DO 10 K = 1, N
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+            SELECT( K ) = .FALSE.
+         ELSE
+            IF( WI( K ).EQ.ZERO ) THEN
+               IF( SELECT( K ) )
+     $            M = M + 1
+            ELSE
+               PAIR = .TRUE.
+               IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
+                  SELECT( K ) = .TRUE.
+                  M = M + 2
+               END IF
+            END IF
+         END IF
+   10 CONTINUE
+*
+      INFO = 0
+      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -1
+      ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+         INFO = -11
+      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SHSEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set machine-dependent constants.
+*
+      UNFL = SLAMCH( 'Safe minimum' )
+      ULP = SLAMCH( 'Precision' )
+      SMLNUM = UNFL*( N / ULP )
+      BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+      LDWORK = N + 1
+*
+      KL = 1
+      KLN = 0
+      IF( FROMQR ) THEN
+         KR = 0
+      ELSE
+         KR = N
+      END IF
+      KSR = 1
+*
+      DO 120 K = 1, N
+         IF( SELECT( K ) ) THEN
+*
+*           Compute eigenvector(s) corresponding to W(K).
+*
+            IF( FROMQR ) THEN
+*
+*              If affiliation of eigenvalues is known, check whether
+*              the matrix splits.
+*
+*              Determine KL and KR such that 1 <= KL <= K <= KR <= N
+*              and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
+*              KR = N).
+*
+*              Then inverse iteration can be performed with the
+*              submatrix H(KL:N,KL:N) for a left eigenvector, and with
+*              the submatrix H(1:KR,1:KR) for a right eigenvector.
+*
+               DO 20 I = K, KL + 1, -1
+                  IF( H( I, I-1 ).EQ.ZERO )
+     $               GO TO 30
+   20          CONTINUE
+   30          CONTINUE
+               KL = I
+               IF( K.GT.KR ) THEN
+                  DO 40 I = K, N - 1
+                     IF( H( I+1, I ).EQ.ZERO )
+     $                  GO TO 50
+   40             CONTINUE
+   50             CONTINUE
+                  KR = I
+               END IF
+            END IF
+*
+            IF( KL.NE.KLN ) THEN
+               KLN = KL
+*
+*              Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
+*              has not ben computed before.
+*
+               HNORM = SLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
+               IF( HNORM.GT.ZERO ) THEN
+                  EPS3 = HNORM*ULP
+               ELSE
+                  EPS3 = SMLNUM
+               END IF
+            END IF
+*
+*           Perturb eigenvalue if it is close to any previous
+*           selected eigenvalues affiliated to the submatrix
+*           H(KL:KR,KL:KR). Close roots are modified by EPS3.
+*
+            WKR = WR( K )
+            WKI = WI( K )
+   60       CONTINUE
+            DO 70 I = K - 1, KL, -1
+               IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
+     $             ABS( WI( I )-WKI ).LT.EPS3 ) THEN
+                  WKR = WKR + EPS3
+                  GO TO 60
+               END IF
+   70       CONTINUE
+            WR( K ) = WKR
+*
+            PAIR = WKI.NE.ZERO
+            IF( PAIR ) THEN
+               KSI = KSR + 1
+            ELSE
+               KSI = KSR
+            END IF
+            IF( LEFTV ) THEN
+*
+*              Compute left eigenvector.
+*
+               CALL SLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
+     $                      WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
+     $                      WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
+     $                      BIGNUM, IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  IF( PAIR ) THEN
+                     INFO = INFO + 2
+                  ELSE
+                     INFO = INFO + 1
+                  END IF
+                  IFAILL( KSR ) = K
+                  IFAILL( KSI ) = K
+               ELSE
+                  IFAILL( KSR ) = 0
+                  IFAILL( KSI ) = 0
+               END IF
+               DO 80 I = 1, KL - 1
+                  VL( I, KSR ) = ZERO
+   80          CONTINUE
+               IF( PAIR ) THEN
+                  DO 90 I = 1, KL - 1
+                     VL( I, KSI ) = ZERO
+   90             CONTINUE
+               END IF
+            END IF
+            IF( RIGHTV ) THEN
+*
+*              Compute right eigenvector.
+*
+               CALL SLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
+     $                      VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
+     $                      WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
+     $                      IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  IF( PAIR ) THEN
+                     INFO = INFO + 2
+                  ELSE
+                     INFO = INFO + 1
+                  END IF
+                  IFAILR( KSR ) = K
+                  IFAILR( KSI ) = K
+               ELSE
+                  IFAILR( KSR ) = 0
+                  IFAILR( KSI ) = 0
+               END IF
+               DO 100 I = KR + 1, N
+                  VR( I, KSR ) = ZERO
+  100          CONTINUE
+               IF( PAIR ) THEN
+                  DO 110 I = KR + 1, N
+                     VR( I, KSI ) = ZERO
+  110             CONTINUE
+               END IF
+            END IF
+*
+            IF( PAIR ) THEN
+               KSR = KSR + 2
+            ELSE
+               KSR = KSR + 1
+            END IF
+         END IF
+  120 CONTINUE
+*
+      RETURN
+*
+*     End of SHSEIN
+*
+      END
diff --git a/SRC/shseqr.f b/SRC/shseqr.f
new file mode 100644
index 00000000..5f5ee19f
--- /dev/null
+++ b/SRC/shseqr.f
@@ -0,0 +1,407 @@
+      SUBROUTINE SHSEQR( 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 ..
+      REAL               H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*     Purpose
+*     =======
+*
+*     SHSEQR 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 SGEBAL, and then passed to SGEHRD
+*           when the matrix output by SGEBAL 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) REAL 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 SHSEQR, 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) REAL array, dimension (N)
+*     WI    (output) REAL 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) REAL 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 SORGHR
+*           after the call to SGEHRD 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) REAL 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 SHSEQR does a workspace query.
+*           In this case, SHSEQR 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, SHSEQR 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,'SHSEQR',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 SLAHQR vs SLAQR0 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
+*                       SLAHQR 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
+*     .    SLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== NL allocates some local workspace to help small matrices
+*     .    through a rare SLAHQR 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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
+*     ..
+*     .. Local Arrays ..
+      REAL               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           SLACPY, SLAHQR, SLAQR0, SLASET, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Decode and check the input parameters. ====
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+      WORK( 1 ) = REAL( 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( 'SHSEQR', -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 SLAQR0( 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( REAL( MAX( 1, N ) ), WORK( 1 ) )
+         RETURN
+*
+      ELSE
+*
+*        ==== copy eigenvalues isolated by SGEBAL ====
+*
+         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 SLASET( '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
+*
+*        ==== SLAHQR/SLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 1, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
+     $          IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== SLAQR0 for big matrices; SLAHQR for small ones ====
+*
+         IF( N.GT.NMIN ) THEN
+            CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+     $                   IHI, Z, LDZ, WORK, LWORK, INFO )
+         ELSE
+*
+*           ==== Small matrix ====
+*
+            CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+     $                   IHI, Z, LDZ, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+*
+*              ==== A rare SLAHQR failure!  SLAQR0 sometimes succeeds
+*              .    when SLAHQR fails. ====
+*
+               KBOT = INFO
+*
+               IF( N.GE.NL ) THEN
+*
+*                 ==== Larger matrices have enough subdiagonal scratch
+*                 .    space to call SLAQR0 directly. ====
+*
+                  CALL SLAQR0( 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 SLAQR0.  Hence,
+*                 .    tiny matrices must be copied into a larger
+*                 .    array before calling SLAQR0. ====
+*
+                  CALL SLACPY( 'A', N, N, H, LDH, HL, NL )
+                  HL( N+1, N ) = ZERO
+                  CALL SLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+     $                         NL )
+                  CALL SLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
+     $                         WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+                  IF( WANTT .OR. INFO.NE.0 )
+     $               CALL SLACPY( '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 SLASET( '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( REAL( MAX( 1, N ) ), WORK( 1 ) )
+      END IF
+*
+*     ==== End of SHSEQR ====
+*
+      END
diff --git a/SRC/sisnan.f b/SRC/sisnan.f
new file mode 100644
index 00000000..352d70ef
--- /dev/null
+++ b/SRC/sisnan.f
@@ -0,0 +1,33 @@
+      FUNCTION SISNAN( SIN )
+      LOGICAL SISNAN
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      REAL             SIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SISNAN returns .TRUE. if its argument is NaN, and .FALSE.
+*  otherwise.  To be replaced by the Fortran 2003 intrinsic in the
+*  future.
+*
+*  Arguments
+*  =========
+*
+*  SIN      (input) REAL
+*          Input to test for NaN.
+*
+*  =====================================================================
+*
+*  .. External Functions ..
+      LOGICAL SLAISNAN
+      EXTERNAL SLAISNAN
+*  ..
+*  .. Executable Statements ..
+      SISNAN = SLAISNAN( SIN, SIN )
+      END FUNCTION
diff --git a/SRC/slabad.f b/SRC/slabad.f
new file mode 100644
index 00000000..6de6a312
--- /dev/null
+++ b/SRC/slabad.f
@@ -0,0 +1,55 @@
+      SUBROUTINE SLABAD( SMALL, LARGE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      REAL               LARGE, SMALL
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLABAD takes as input the values computed by SLAMCH 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 SLAMCH.  This subroutine is needed because
+*  SLAMCH does not compensate for poor arithmetic in the upper half of
+*  the exponent range, as is found on a Cray.
+*
+*  Arguments
+*  =========
+*
+*  SMALL   (input/output) REAL
+*          On entry, the underflow threshold as computed by SLAMCH.
+*          On exit, if LOG10(LARGE) is sufficiently large, the square
+*          root of SMALL, otherwise unchanged.
+*
+*  LARGE   (input/output) REAL
+*          On entry, the overflow threshold as computed by SLAMCH.
+*          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. ) THEN
+         SMALL = SQRT( SMALL )
+         LARGE = SQRT( LARGE )
+      END IF
+*
+      RETURN
+*
+*     End of SLABAD
+*
+      END
diff --git a/SRC/slabrd.f b/SRC/slabrd.f
new file mode 100644
index 00000000..c11b23e0
--- /dev/null
+++ b/SRC/slabrd.f
@@ -0,0 +1,290 @@
+      SUBROUTINE SLABRD( 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 ..
+      REAL               A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), X( LDX, * ), Y( LDY, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLABRD 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 SGEBRD
+*
+*  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) REAL 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) REAL array, dimension (NB)
+*          The diagonal elements of the first NB rows and columns of
+*          the reduced matrix.  D(i) = A(i,i).
+*
+*  E       (output) REAL array, dimension (NB)
+*          The off-diagonal elements of the first NB rows and columns of
+*          the reduced matrix.
+*
+*  TAUQ    (output) REAL array dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q. See Further Details.
+*
+*  TAUP    (output) REAL array, dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix P. See Further Details.
+*
+*  X       (output) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SLARFG, SSCAL
+*     ..
+*     .. 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 SGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
+            CALL SGEMV( '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 SLARFG( 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 SGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
+     $                     LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
+     $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
+     $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+*
+*              Update A(i,i+1:n)
+*
+               CALL SGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
+     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
+               CALL SGEMV( '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 SLARFG( 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 SGEMV( '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 SGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
+     $                     A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL SSCAL( 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 SGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
+     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
+            CALL SGEMV( '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 SLARFG( 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 SGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
+     $                     A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL SGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+*
+*              Update A(i+1:m,i)
+*
+               CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
+               CALL SGEMV( '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 SLARFG( 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 SGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+     $                     LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
+     $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL SGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
+     $                     Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of SLABRD
+*
+      END
diff --git a/SRC/slacn2.f b/SRC/slacn2.f
new file mode 100644
index 00000000..7ee6a41d
--- /dev/null
+++ b/SRC/slacn2.f
@@ -0,0 +1,214 @@
+      SUBROUTINE SLACN2( 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
+      REAL               EST
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISGN( * ), ISAVE( 3 )
+      REAL               V( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLACN2 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) REAL array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) REAL array, dimension (N)
+*         On an intermediate return, X should be overwritten by
+*               A * X,   if KASE=1,
+*               A' * X,  if KASE=2,
+*         and SLACN2 must be re-called with all the other parameters
+*         unchanged.
+*
+*  ISGN   (workspace) INTEGER array, dimension (N)
+*
+*  EST    (input/output) REAL
+*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
+*         unchanged from the previous call to SLACN2.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to SLACN2, 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 SLACN2, KASE will again be 0.
+*
+*  ISAVE  (input/output) INTEGER array, dimension (3)
+*         ISAVE is used to save variables between calls to SLACN2
+*
+*  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 SLACON, which uses the array ISAVE
+*  in place of a SAVE statement, as follows:
+*
+*     SLACON     SLACN2
+*      JUMP     ISAVE(1)
+*      J        ISAVE(2)
+*      ITER     ISAVE(3)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, JLAST
+      REAL               ALTSGN, ESTOLD, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SASUM
+      EXTERNAL           ISAMAX, SASUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, NINT, REAL, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = ONE / REAL( 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 = SASUM( 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 ) = ISAMAX( 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 SCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = SASUM( 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 ) = ISAMAX( 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+REAL( I-1 ) / REAL( 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*( SASUM( N, X, 1 ) / REAL( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL SCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  150 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of SLACN2
+*
+      END
diff --git a/SRC/slacon.f b/SRC/slacon.f
new file mode 100644
index 00000000..1d50b5f6
--- /dev/null
+++ b/SRC/slacon.f
@@ -0,0 +1,205 @@
+      SUBROUTINE SLACON( 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
+      REAL               EST
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISGN( * )
+      REAL               V( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLACON 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) REAL array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) REAL array, dimension (N)
+*         On an intermediate return, X should be overwritten by
+*               A * X,   if KASE=1,
+*               A' * X,  if KASE=2,
+*         and SLACON must be re-called with all the other parameters
+*         unchanged.
+*
+*  ISGN   (workspace) INTEGER array, dimension (N)
+*
+*  EST    (input/output) REAL
+*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
+*         unchanged from the previous call to SLACON.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to SLACON, 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 SLACON, 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 )
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITER, J, JLAST, JUMP
+      REAL               ALTSGN, ESTOLD, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SASUM
+      EXTERNAL           ISAMAX, SASUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, NINT, REAL, SIGN
+*     ..
+*     .. Save statement ..
+      SAVE
+*     ..
+*     .. Executable Statements ..
+*
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = ONE / REAL( 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 = SASUM( 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 = ISAMAX( 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 SCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = SASUM( 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 = ISAMAX( 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+REAL( I-1 ) / REAL( 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*( SASUM( N, X, 1 ) / REAL( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL SCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  150 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of SLACON
+*
+      END
diff --git a/SRC/slacpy.f b/SRC/slacpy.f
new file mode 100644
index 00000000..993705d1
--- /dev/null
+++ b/SRC/slacpy.f
@@ -0,0 +1,87 @@
+      SUBROUTINE SLACPY( 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 ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLACPY 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) REAL 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) REAL 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 SLACPY
+*
+      END
diff --git a/SRC/sladiv.f b/SRC/sladiv.f
new file mode 100644
index 00000000..f487d55c
--- /dev/null
+++ b/SRC/sladiv.f
@@ -0,0 +1,62 @@
+      SUBROUTINE SLADIV( 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 ..
+      REAL               A, B, C, D, P, Q
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLADIV 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) REAL
+*  B       (input) REAL
+*  C       (input) REAL
+*  D       (input) REAL
+*          The scalars a, b, c, and d in the above expression.
+*
+*  P       (output) REAL
+*  Q       (output) REAL
+*          The scalars p and q in the above expression.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      REAL               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 SLADIV
+*
+      END
diff --git a/SRC/slae2.f b/SRC/slae2.f
new file mode 100644
index 00000000..beb45950
--- /dev/null
+++ b/SRC/slae2.f
@@ -0,0 +1,123 @@
+      SUBROUTINE SLAE2( 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 ..
+      REAL               A, B, C, RT1, RT2
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAE2  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) REAL
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  B       (input) REAL
+*          The (1,2) and (2,1) elements of the 2-by-2 matrix.
+*
+*  C       (input) REAL
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  RT1     (output) REAL
+*          The eigenvalue of larger absolute value.
+*
+*  RT2     (output) REAL
+*          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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E0 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               HALF
+      PARAMETER          ( HALF = 0.5E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 SLAE2
+*
+      END
diff --git a/SRC/slaebz.f b/SRC/slaebz.f
new file mode 100644
index 00000000..82af82af
--- /dev/null
+++ b/SRC/slaebz.f
@@ -0,0 +1,551 @@
+      SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
+     $                   RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
+     $                   NAB, WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
+      REAL               ABSTOL, PIVMIN, RELTOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * ), NAB( MMAX, * ), NVAL( * )
+      REAL               AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAEBZ contains the iteration loops which compute and use the
+*  function N(w), which is the count of eigenvalues of a symmetric
+*  tridiagonal matrix T less than or equal to its argument  w.  It
+*  performs a choice of two types of loops:
+*
+*  IJOB=1, followed by
+*  IJOB=2: It takes as input a list of intervals and returns a list of
+*          sufficiently small intervals whose union contains the same
+*          eigenvalues as the union of the original intervals.
+*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
+*          The output interval (AB(j,1),AB(j,2)] will contain
+*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
+*
+*  IJOB=3: It performs a binary search in each input interval
+*          (AB(j,1),AB(j,2)] for a point  w(j)  such that
+*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of
+*          the search.  If such a w(j) is found, then on output
+*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output
+*          (AB(j,1),AB(j,2)] will be a small interval containing the
+*          point where N(w) jumps through NVAL(j), unless that point
+*          lies outside the initial interval.
+*
+*  Note that the intervals are in all cases half-open intervals,
+*  i.e., of the form  (a,b] , which includes  b  but not  a .
+*
+*  To avoid underflow, the matrix should be scaled so that its largest
+*  element is no greater than  overflow**(1/2) * underflow**(1/4)
+*  in absolute value.  To assure the most accurate computation
+*  of small eigenvalues, the matrix should be scaled to be
+*  not much smaller than that, either.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966
+*
+*  Note: the arguments are, in general, *not* checked for unreasonable
+*  values.
+*
+*  Arguments
+*  =========
+*
+*  IJOB    (input) INTEGER
+*          Specifies what is to be done:
+*          = 1:  Compute NAB for the initial intervals.
+*          = 2:  Perform bisection iteration to find eigenvalues of T.
+*          = 3:  Perform bisection iteration to invert N(w), i.e.,
+*                to find a point which has a specified number of
+*                eigenvalues of T to its left.
+*          Other values will cause SLAEBZ to return with INFO=-1.
+*
+*  NITMAX  (input) INTEGER
+*          The maximum number of "levels" of bisection to be
+*          performed, i.e., an interval of width W will not be made
+*          smaller than 2^(-NITMAX) * W.  If not all intervals
+*          have converged after NITMAX iterations, then INFO is set
+*          to the number of non-converged intervals.
+*
+*  N       (input) INTEGER
+*          The dimension n of the tridiagonal matrix T.  It must be at
+*          least 1.
+*
+*  MMAX    (input) INTEGER
+*          The maximum number of intervals.  If more than MMAX intervals
+*          are generated, then SLAEBZ will quit with INFO=MMAX+1.
+*
+*  MINP    (input) INTEGER
+*          The initial number of intervals.  It may not be greater than
+*          MMAX.
+*
+*  NBMIN   (input) INTEGER
+*          The smallest number of intervals that should be processed
+*          using a vector loop.  If zero, then only the scalar loop
+*          will be used.
+*
+*  ABSTOL  (input) REAL
+*          The minimum (absolute) width of an interval.  When an
+*          interval is narrower than ABSTOL, or than RELTOL times the
+*          larger (in magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  This must be at least
+*          zero.
+*
+*  RELTOL  (input) REAL
+*          The minimum relative width of an interval.  When an interval
+*          is narrower than ABSTOL, or than RELTOL times the larger (in
+*          magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  Note: this should
+*          always be at least radix*machine epsilon.
+*
+*  PIVMIN  (input) REAL
+*          The minimum absolute value of a "pivot" in the Sturm
+*          sequence loop.  This *must* be at least  max |e(j)**2| *
+*          safe_min  and at least safe_min, where safe_min is at least
+*          the smallest number that can divide one without overflow.
+*
+*  D       (input) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) REAL array, dimension (N)
+*          The offdiagonal elements of the tridiagonal matrix T in
+*          positions 1 through N-1.  E(N) is arbitrary.
+*
+*  E2      (input) REAL array, dimension (N)
+*          The squares of the offdiagonal elements of the tridiagonal
+*          matrix T.  E2(N) is ignored.
+*
+*  NVAL    (input/output) INTEGER array, dimension (MINP)
+*          If IJOB=1 or 2, not referenced.
+*          If IJOB=3, the desired values of N(w).  The elements of NVAL
+*          will be reordered to correspond with the intervals in AB.
+*          Thus, NVAL(j) on output will not, in general be the same as
+*          NVAL(j) on input, but it will correspond with the interval
+*          (AB(j,1),AB(j,2)] on output.
+*
+*  AB      (input/output) REAL array, dimension (MMAX,2)
+*          The endpoints of the intervals.  AB(j,1) is  a(j), the left
+*          endpoint of the j-th interval, and AB(j,2) is b(j), the
+*          right endpoint of the j-th interval.  The input intervals
+*          will, in general, be modified, split, and reordered by the
+*          calculation.
+*
+*  C       (input/output) REAL array, dimension (MMAX)
+*          If IJOB=1, ignored.
+*          If IJOB=2, workspace.
+*          If IJOB=3, then on input C(j) should be initialized to the
+*          first search point in the binary search.
+*
+*  MOUT    (output) INTEGER
+*          If IJOB=1, the number of eigenvalues in the intervals.
+*          If IJOB=2 or 3, the number of intervals output.
+*          If IJOB=3, MOUT will equal MINP.
+*
+*  NAB     (input/output) INTEGER array, dimension (MMAX,2)
+*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
+*          If IJOB=2, then on input, NAB(i,j) should be set.  It must
+*             satisfy the condition:
+*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
+*             which means that in interval i only eigenvalues
+*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually,
+*             NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with
+*             IJOB=1.
+*             On output, NAB(i,j) will contain
+*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
+*             the input interval that the output interval
+*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
+*             the input values of NAB(k,1) and NAB(k,2).
+*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
+*             unless N(w) > NVAL(i) for all search points  w , in which
+*             case NAB(i,1) will not be modified, i.e., the output
+*             value will be the same as the input value (modulo
+*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
+*             for all search points  w , in which case NAB(i,2) will
+*             not be modified.  Normally, NAB should be set to some
+*             distinctive value(s) before SLAEBZ is called.
+*
+*  WORK    (workspace) REAL array, dimension (MMAX)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MMAX)
+*          Workspace.
+*
+*  INFO    (output) INTEGER
+*          = 0:       All intervals converged.
+*          = 1--MMAX: The last INFO intervals did not converge.
+*          = MMAX+1:  More than MMAX intervals were generated.
+*
+*  Further Details
+*  ===============
+*
+*      This routine is intended to be called only by other LAPACK
+*  routines, thus the interface is less user-friendly.  It is intended
+*  for two purposes:
+*
+*  (a) finding eigenvalues.  In this case, SLAEBZ should have one or
+*      more initial intervals set up in AB, and SLAEBZ should be called
+*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.
+*      Intervals with no eigenvalues would usually be thrown out at
+*      this point.  Also, if not all the eigenvalues in an interval i
+*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
+*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
+*      eigenvalue.  SLAEBZ is then called with IJOB=2 and MMAX
+*      no smaller than the value of MOUT returned by the call with
+*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1
+*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
+*      tolerance specified by ABSTOL and RELTOL.
+*
+*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
+*      In this case, start with a Gershgorin interval  (a,b).  Set up
+*      AB to contain 2 search intervals, both initially (a,b).  One
+*      NVAL element should contain  f-1  and the other should contain  l
+*      , while C should contain a and b, resp.  NAB(i,1) should be -1
+*      and NAB(i,2) should be N+1, to flag an error if the desired
+*      interval does not lie in (a,b).  SLAEBZ is then called with
+*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --
+*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
+*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
+*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and
+*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and
+*      w(l-r)=...=w(l+k) are handled similarly.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, TWO, HALF
+      PARAMETER          ( ZERO = 0.0E0, TWO = 2.0E0,
+     $                   HALF = 1.0E0 / TWO )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
+     $                   KLNEW
+      REAL               TMP1, TMP2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Check for Errors
+*
+      INFO = 0
+      IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
+         INFO = -1
+         RETURN
+      END IF
+*
+*     Initialize NAB
+*
+      IF( IJOB.EQ.1 ) THEN
+*
+*        Compute the number of eigenvalues in the initial intervals.
+*
+         MOUT = 0
+CDIR$ NOVECTOR
+         DO 30 JI = 1, MINP
+            DO 20 JP = 1, 2
+               TMP1 = D( 1 ) - AB( JI, JP )
+               IF( ABS( TMP1 ).LT.PIVMIN )
+     $            TMP1 = -PIVMIN
+               NAB( JI, JP ) = 0
+               IF( TMP1.LE.ZERO )
+     $            NAB( JI, JP ) = 1
+*
+               DO 10 J = 2, N
+                  TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
+                  IF( ABS( TMP1 ).LT.PIVMIN )
+     $               TMP1 = -PIVMIN
+                  IF( TMP1.LE.ZERO )
+     $               NAB( JI, JP ) = NAB( JI, JP ) + 1
+   10          CONTINUE
+   20       CONTINUE
+            MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
+   30    CONTINUE
+         RETURN
+      END IF
+*
+*     Initialize for loop
+*
+*     KF and KL have the following meaning:
+*        Intervals 1,...,KF-1 have converged.
+*        Intervals KF,...,KL  still need to be refined.
+*
+      KF = 1
+      KL = MINP
+*
+*     If IJOB=2, initialize C.
+*     If IJOB=3, use the user-supplied starting point.
+*
+      IF( IJOB.EQ.2 ) THEN
+         DO 40 JI = 1, MINP
+            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+   40    CONTINUE
+      END IF
+*
+*     Iteration loop
+*
+      DO 130 JIT = 1, NITMAX
+*
+*        Loop over intervals
+*
+         IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
+*
+*           Begin of Parallel Version of the loop
+*
+            DO 60 JI = KF, KL
+*
+*              Compute N(c), the number of eigenvalues less than c
+*
+               WORK( JI ) = D( 1 ) - C( JI )
+               IWORK( JI ) = 0
+               IF( WORK( JI ).LE.PIVMIN ) THEN
+                  IWORK( JI ) = 1
+                  WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+               END IF
+*
+               DO 50 J = 2, N
+                  WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
+                  IF( WORK( JI ).LE.PIVMIN ) THEN
+                     IWORK( JI ) = IWORK( JI ) + 1
+                     WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+                  END IF
+   50          CONTINUE
+   60       CONTINUE
+*
+            IF( IJOB.LE.2 ) THEN
+*
+*              IJOB=2: Choose all intervals containing eigenvalues.
+*
+               KLNEW = KL
+               DO 70 JI = KF, KL
+*
+*                 Insure that N(w) is monotone
+*
+                  IWORK( JI ) = MIN( NAB( JI, 2 ),
+     $                          MAX( NAB( JI, 1 ), IWORK( JI ) ) )
+*
+*                 Update the Queue -- add intervals if both halves
+*                 contain eigenvalues.
+*
+                  IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
+*
+*                    No eigenvalue in the upper interval:
+*                    just use the lower interval.
+*
+                     AB( JI, 2 ) = C( JI )
+*
+                  ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
+*
+*                    No eigenvalue in the lower interval:
+*                    just use the upper interval.
+*
+                     AB( JI, 1 ) = C( JI )
+                  ELSE
+                     KLNEW = KLNEW + 1
+                     IF( KLNEW.LE.MMAX ) THEN
+*
+*                       Eigenvalue in both intervals -- add upper to
+*                       queue.
+*
+                        AB( KLNEW, 2 ) = AB( JI, 2 )
+                        NAB( KLNEW, 2 ) = NAB( JI, 2 )
+                        AB( KLNEW, 1 ) = C( JI )
+                        NAB( KLNEW, 1 ) = IWORK( JI )
+                        AB( JI, 2 ) = C( JI )
+                        NAB( JI, 2 ) = IWORK( JI )
+                     ELSE
+                        INFO = MMAX + 1
+                     END IF
+                  END IF
+   70          CONTINUE
+               IF( INFO.NE.0 )
+     $            RETURN
+               KL = KLNEW
+            ELSE
+*
+*              IJOB=3: Binary search.  Keep only the interval containing
+*                      w   s.t. N(w) = NVAL
+*
+               DO 80 JI = KF, KL
+                  IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
+                     AB( JI, 1 ) = C( JI )
+                     NAB( JI, 1 ) = IWORK( JI )
+                  END IF
+                  IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
+                     AB( JI, 2 ) = C( JI )
+                     NAB( JI, 2 ) = IWORK( JI )
+                  END IF
+   80          CONTINUE
+            END IF
+*
+         ELSE
+*
+*           End of Parallel Version of the loop
+*
+*           Begin of Serial Version of the loop
+*
+            KLNEW = KL
+            DO 100 JI = KF, KL
+*
+*              Compute N(w), the number of eigenvalues less than w
+*
+               TMP1 = C( JI )
+               TMP2 = D( 1 ) - TMP1
+               ITMP1 = 0
+               IF( TMP2.LE.PIVMIN ) THEN
+                  ITMP1 = 1
+                  TMP2 = MIN( TMP2, -PIVMIN )
+               END IF
+*
+*              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 90 J = 2, N
+                  TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
+                  IF( TMP2.LE.PIVMIN ) THEN
+                     ITMP1 = ITMP1 + 1
+                     TMP2 = MIN( TMP2, -PIVMIN )
+                  END IF
+   90          CONTINUE
+*
+               IF( IJOB.LE.2 ) THEN
+*
+*                 IJOB=2: Choose all intervals containing eigenvalues.
+*
+*                 Insure that N(w) is monotone
+*
+                  ITMP1 = MIN( NAB( JI, 2 ),
+     $                    MAX( NAB( JI, 1 ), ITMP1 ) )
+*
+*                 Update the Queue -- add intervals if both halves
+*                 contain eigenvalues.
+*
+                  IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
+*
+*                    No eigenvalue in the upper interval:
+*                    just use the lower interval.
+*
+                     AB( JI, 2 ) = TMP1
+*
+                  ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
+*
+*                    No eigenvalue in the lower interval:
+*                    just use the upper interval.
+*
+                     AB( JI, 1 ) = TMP1
+                  ELSE IF( KLNEW.LT.MMAX ) THEN
+*
+*                    Eigenvalue in both intervals -- add upper to queue.
+*
+                     KLNEW = KLNEW + 1
+                     AB( KLNEW, 2 ) = AB( JI, 2 )
+                     NAB( KLNEW, 2 ) = NAB( JI, 2 )
+                     AB( KLNEW, 1 ) = TMP1
+                     NAB( KLNEW, 1 ) = ITMP1
+                     AB( JI, 2 ) = TMP1
+                     NAB( JI, 2 ) = ITMP1
+                  ELSE
+                     INFO = MMAX + 1
+                     RETURN
+                  END IF
+               ELSE
+*
+*                 IJOB=3: Binary search.  Keep only the interval
+*                         containing  w  s.t. N(w) = NVAL
+*
+                  IF( ITMP1.LE.NVAL( JI ) ) THEN
+                     AB( JI, 1 ) = TMP1
+                     NAB( JI, 1 ) = ITMP1
+                  END IF
+                  IF( ITMP1.GE.NVAL( JI ) ) THEN
+                     AB( JI, 2 ) = TMP1
+                     NAB( JI, 2 ) = ITMP1
+                  END IF
+               END IF
+  100       CONTINUE
+            KL = KLNEW
+*
+*           End of Serial Version of the loop
+*
+         END IF
+*
+*        Check for convergence
+*
+         KFNEW = KF
+         DO 110 JI = KF, KL
+            TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
+            TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
+            IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
+     $          NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
+*
+*              Converged -- Swap with position KFNEW,
+*                           then increment KFNEW
+*
+               IF( JI.GT.KFNEW ) THEN
+                  TMP1 = AB( JI, 1 )
+                  TMP2 = AB( JI, 2 )
+                  ITMP1 = NAB( JI, 1 )
+                  ITMP2 = NAB( JI, 2 )
+                  AB( JI, 1 ) = AB( KFNEW, 1 )
+                  AB( JI, 2 ) = AB( KFNEW, 2 )
+                  NAB( JI, 1 ) = NAB( KFNEW, 1 )
+                  NAB( JI, 2 ) = NAB( KFNEW, 2 )
+                  AB( KFNEW, 1 ) = TMP1
+                  AB( KFNEW, 2 ) = TMP2
+                  NAB( KFNEW, 1 ) = ITMP1
+                  NAB( KFNEW, 2 ) = ITMP2
+                  IF( IJOB.EQ.3 ) THEN
+                     ITMP1 = NVAL( JI )
+                     NVAL( JI ) = NVAL( KFNEW )
+                     NVAL( KFNEW ) = ITMP1
+                  END IF
+               END IF
+               KFNEW = KFNEW + 1
+            END IF
+  110    CONTINUE
+         KF = KFNEW
+*
+*        Choose Midpoints
+*
+         DO 120 JI = KF, KL
+            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+  120    CONTINUE
+*
+*        If no more intervals to refine, quit.
+*
+         IF( KF.GT.KL )
+     $      GO TO 140
+  130 CONTINUE
+*
+*     Converged
+*
+  140 CONTINUE
+      INFO = MAX( KL+1-KF, 0 )
+      MOUT = KL
+*
+      RETURN
+*
+*     End of SLAEBZ
+*
+      END
diff --git a/SRC/slaed0.f b/SRC/slaed0.f
new file mode 100644
index 00000000..a4844214
--- /dev/null
+++ b/SRC/slaed0.f
@@ -0,0 +1,349 @@
+      SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED0 computes all eigenvalues and corresponding eigenvectors of a
+*  symmetric tridiagonal matrix using the divide and conquer method.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          = 0:  Compute eigenvalues only.
+*          = 1:  Compute eigenvectors of original dense symmetric matrix
+*                also.  On entry, Q contains the orthogonal matrix used
+*                to reduce the original matrix to tridiagonal form.
+*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
+*                matrix.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the orthogonal matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, the main diagonal of the tridiagonal matrix.
+*         On exit, its eigenvalues.
+*
+*  E      (input) REAL array, dimension (N-1)
+*         The off-diagonal elements of the tridiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  Q      (input/output) REAL array, dimension (LDQ, N)
+*         On entry, Q must contain an N-by-N orthogonal matrix.
+*         If ICOMPQ = 0    Q is not referenced.
+*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
+*                          orthogonal matrix used to reduce the full
+*                          matrix to tridiagonal form corresponding to
+*                          the subset of the full matrix which is being
+*                          decomposed at this time.
+*         If ICOMPQ = 2    On entry, Q will be the identity matrix.
+*                          On exit, Q contains the eigenvectors of the
+*                          tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  If eigenvectors are
+*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
+*
+*  QSTORE (workspace) REAL array, dimension (LDQS, N)
+*         Referenced only when ICOMPQ = 1.  Used to store parts of
+*         the eigenvector matrix when the updating matrix multiplies
+*         take place.
+*
+*  LDQS   (input) INTEGER
+*         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
+*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
+*
+*  WORK   (workspace) REAL array,
+*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
+*                     1 + 3*N + 2*N*lg N + 2*N**2
+*                     ( lg( N ) = smallest integer k
+*                                 such that 2^k >= N )
+*         If ICOMPQ = 2, the dimension of WORK must be at least
+*                     4*N + N**2.
+*
+*  IWORK  (workspace) INTEGER array,
+*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
+*                        6 + 6*N + 5*N*lg N.
+*                        ( lg( N ) = smallest integer k
+*                                    such that 2^k >= N )
+*         If ICOMPQ = 2, the dimension of IWORK must be at least
+*                        3 + 5*N.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.E0, ONE = 1.E0, TWO = 2.E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
+     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
+     $                   J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
+     $                   SPM2, SUBMAT, SUBPBS, TLVLS
+      REAL               TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, SLACPY, SLAED1, SLAED7, SSTEQR,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
+         INFO = -1
+      ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED0', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 0, 0, 0, 0 )
+*
+*     Determine the size and placement of the submatrices, and save in
+*     the leading elements of IWORK.
+*
+      IWORK( 1 ) = N
+      SUBPBS = 1
+      TLVLS = 0
+   10 CONTINUE
+      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
+         DO 20 J = SUBPBS, 1, -1
+            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
+            IWORK( 2*J-1 ) = IWORK( J ) / 2
+   20    CONTINUE
+         TLVLS = TLVLS + 1
+         SUBPBS = 2*SUBPBS
+         GO TO 10
+      END IF
+      DO 30 J = 2, SUBPBS
+         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
+   30 CONTINUE
+*
+*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
+*     using rank-1 modifications (cuts).
+*
+      SPM1 = SUBPBS - 1
+      DO 40 I = 1, SPM1
+         SUBMAT = IWORK( I ) + 1
+         SMM1 = SUBMAT - 1
+         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
+         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
+   40 CONTINUE
+*
+      INDXQ = 4*N + 3
+      IF( ICOMPQ.NE.2 ) THEN
+*
+*        Set up workspaces for eigenvalues only/accumulate new vectors
+*        routine
+*
+         TEMP = LOG( REAL( N ) ) / LOG( TWO )
+         LGN = INT( TEMP )
+         IF( 2**LGN.LT.N )
+     $      LGN = LGN + 1
+         IF( 2**LGN.LT.N )
+     $      LGN = LGN + 1
+         IPRMPT = INDXQ + N + 1
+         IPERM = IPRMPT + N*LGN
+         IQPTR = IPERM + N*LGN
+         IGIVPT = IQPTR + N + 2
+         IGIVCL = IGIVPT + N*LGN
+*
+         IGIVNM = 1
+         IQ = IGIVNM + 2*N*LGN
+         IWREM = IQ + N**2 + 1
+*
+*        Initialize pointers
+*
+         DO 50 I = 0, SUBPBS
+            IWORK( IPRMPT+I ) = 1
+            IWORK( IGIVPT+I ) = 1
+   50    CONTINUE
+         IWORK( IQPTR ) = 1
+      END IF
+*
+*     Solve each submatrix eigenproblem at the bottom of the divide and
+*     conquer tree.
+*
+      CURR = 0
+      DO 70 I = 0, SPM1
+         IF( I.EQ.0 ) THEN
+            SUBMAT = 1
+            MATSIZ = IWORK( 1 )
+         ELSE
+            SUBMAT = IWORK( I ) + 1
+            MATSIZ = IWORK( I+1 ) - IWORK( I )
+         END IF
+         IF( ICOMPQ.EQ.2 ) THEN
+            CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+     $                   Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 130
+         ELSE
+            CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+     $                   WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
+     $                   INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 130
+            IF( ICOMPQ.EQ.1 ) THEN
+               CALL SGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
+     $                     Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
+     $                     CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
+     $                     LDQS )
+            END IF
+            IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
+            CURR = CURR + 1
+         END IF
+         K = 1
+         DO 60 J = SUBMAT, IWORK( I+1 )
+            IWORK( INDXQ+J ) = K
+            K = K + 1
+   60    CONTINUE
+   70 CONTINUE
+*
+*     Successively merge eigensystems of adjacent submatrices
+*     into eigensystem for the corresponding larger matrix.
+*
+*     while ( SUBPBS > 1 )
+*
+      CURLVL = 1
+   80 CONTINUE
+      IF( SUBPBS.GT.1 ) THEN
+         SPM2 = SUBPBS - 2
+         DO 90 I = 0, SPM2, 2
+            IF( I.EQ.0 ) THEN
+               SUBMAT = 1
+               MATSIZ = IWORK( 2 )
+               MSD2 = IWORK( 1 )
+               CURPRB = 0
+            ELSE
+               SUBMAT = IWORK( I ) + 1
+               MATSIZ = IWORK( I+2 ) - IWORK( I )
+               MSD2 = MATSIZ / 2
+               CURPRB = CURPRB + 1
+            END IF
+*
+*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
+*     into an eigensystem of size MATSIZ.
+*     SLAED1 is used only for the full eigensystem of a tridiagonal
+*     matrix.
+*     SLAED7 handles the cases in which eigenvalues only or eigenvalues
+*     and eigenvectors of a full symmetric matrix (which was reduced to
+*     tridiagonal form) are desired.
+*
+            IF( ICOMPQ.EQ.2 ) THEN
+               CALL SLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
+     $                      LDQ, IWORK( INDXQ+SUBMAT ),
+     $                      E( SUBMAT+MSD2-1 ), MSD2, WORK,
+     $                      IWORK( SUBPBS+1 ), INFO )
+            ELSE
+               CALL SLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
+     $                      D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
+     $                      IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
+     $                      MSD2, WORK( IQ ), IWORK( IQPTR ),
+     $                      IWORK( IPRMPT ), IWORK( IPERM ),
+     $                      IWORK( IGIVPT ), IWORK( IGIVCL ),
+     $                      WORK( IGIVNM ), WORK( IWREM ),
+     $                      IWORK( SUBPBS+1 ), INFO )
+            END IF
+            IF( INFO.NE.0 )
+     $         GO TO 130
+            IWORK( I / 2+1 ) = IWORK( I+2 )
+   90    CONTINUE
+         SUBPBS = SUBPBS / 2
+         CURLVL = CURLVL + 1
+         GO TO 80
+      END IF
+*
+*     end while
+*
+*     Re-merge the eigenvalues/vectors which were deflated at the final
+*     merge step.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         DO 100 I = 1, N
+            J = IWORK( INDXQ+I )
+            WORK( I ) = D( J )
+            CALL SCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
+  100    CONTINUE
+         CALL SCOPY( N, WORK, 1, D, 1 )
+      ELSE IF( ICOMPQ.EQ.2 ) THEN
+         DO 110 I = 1, N
+            J = IWORK( INDXQ+I )
+            WORK( I ) = D( J )
+            CALL SCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
+  110    CONTINUE
+         CALL SCOPY( N, WORK, 1, D, 1 )
+         CALL SLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
+      ELSE
+         DO 120 I = 1, N
+            J = IWORK( INDXQ+I )
+            WORK( I ) = D( J )
+  120    CONTINUE
+         CALL SCOPY( N, WORK, 1, D, 1 )
+      END IF
+      GO TO 140
+*
+  130 CONTINUE
+      INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+*
+  140 CONTINUE
+      RETURN
+*
+*     End of SLAED0
+*
+      END
diff --git a/SRC/slaed1.f b/SRC/slaed1.f
new file mode 100644
index 00000000..a18a550f
--- /dev/null
+++ b/SRC/slaed1.f
@@ -0,0 +1,195 @@
+      SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CUTPNT, INFO, LDQ, N
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            INDXQ( * ), IWORK( * )
+      REAL               D( * ), Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED1 computes the updated eigensystem of a diagonal
+*  matrix after modification by a rank-one symmetric matrix.  This
+*  routine is used only for the eigenproblem which requires all
+*  eigenvalues and eigenvectors of a tridiagonal matrix.  SLAED7 handles
+*  the case in which eigenvalues only or eigenvalues and eigenvectors
+*  of a full symmetric matrix (which was reduced to tridiagonal form)
+*  are desired.
+*
+*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+*     where Z = Q'u, u is a vector of length N with ones in the
+*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+*     The eigenvectors of the original matrix are stored in Q, and the
+*     eigenvalues are in D.  The algorithm consists of three stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple eigenvalues or if there is a zero in
+*        the Z vector.  For each such occurence the dimension of the
+*        secular equation problem is reduced by one.  This stage is
+*        performed by the routine SLAED2.
+*
+*        The second stage consists of calculating the updated
+*        eigenvalues. This is done by finding the roots of the secular
+*        equation via the routine SLAED4 (as called by SLAED3).
+*        This routine also calculates the eigenvectors of the current
+*        problem.
+*
+*        The final stage consists of computing the updated eigenvectors
+*        directly using the updated eigenvalues.  The eigenvectors for
+*        the current problem are multiplied with the eigenvectors from
+*        the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, the eigenvalues of the rank-1-perturbed matrix.
+*         On exit, the eigenvalues of the repaired matrix.
+*
+*  Q      (input/output) REAL array, dimension (LDQ,N)
+*         On entry, the eigenvectors of the rank-1-perturbed matrix.
+*         On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (input/output) INTEGER array, dimension (N)
+*         On entry, the permutation which separately sorts the two
+*         subproblems in D into ascending order.
+*         On exit, the permutation which will reintegrate the
+*         subproblems back into sorted order,
+*         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  RHO    (input) REAL
+*         The subdiagonal entry used to create the rank-1 modification.
+*
+*  CUTPNT (input) INTEGER
+*         The location of the last eigenvalue in the leading sub-matrix.
+*         min(1,N) <= CUTPNT <= N/2.
+*
+*  WORK   (workspace) REAL array, dimension (4*N + N**2)
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,
+     $                   IQ2, IS, IW, IZ, K, N1, N2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED1', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     The following values are integer pointers which indicate
+*     the portion of the workspace
+*     used by a particular array in SLAED2 and SLAED3.
+*
+      IZ = 1
+      IDLMDA = IZ + N
+      IW = IDLMDA + N
+      IQ2 = IW + N
+*
+      INDX = 1
+      INDXC = INDX + N
+      COLTYP = INDXC + N
+      INDXP = COLTYP + N
+*
+*
+*     Form the z-vector which consists of the last row of Q_1 and the
+*     first row of Q_2.
+*
+      CALL SCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
+      CPP1 = CUTPNT + 1
+      CALL SCOPY( N-CUTPNT, Q( CPP1, CPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
+*
+*     Deflate eigenvalues.
+*
+      CALL SLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
+     $             WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
+     $             IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
+     $             IWORK( COLTYP ), INFO )
+*
+      IF( INFO.NE.0 )
+     $   GO TO 20
+*
+*     Solve Secular Equation.
+*
+      IF( K.NE.0 ) THEN
+         IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
+     $        ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
+         CALL SLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
+     $                WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
+     $                WORK( IW ), WORK( IS ), INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 20
+*
+*     Prepare the INDXQ sorting permutation.
+*
+         N1 = K
+         N2 = N - K
+         CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
+      ELSE
+         DO 10 I = 1, N
+            INDXQ( I ) = I
+   10    CONTINUE
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of SLAED1
+*
+      END
diff --git a/SRC/slaed2.f b/SRC/slaed2.f
new file mode 100644
index 00000000..2731c84b
--- /dev/null
+++ b/SRC/slaed2.f
@@ -0,0 +1,434 @@
+      SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
+     $                   Q2, INDX, INDXC, INDXP, COLTYP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDQ, N, N1
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
+     $                   INDXQ( * )
+      REAL               D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+     $                   W( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED2 merges the two sets of eigenvalues together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  eigenvalues are close together or if there is a tiny entry in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  Arguments
+*  =========
+*
+*  K      (output) INTEGER
+*         The number of non-deflated eigenvalues, and the order of the
+*         related secular equation. 0 <= K <=N.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  N1     (input) INTEGER
+*         The location of the last eigenvalue in the leading sub-matrix.
+*         min(1,N) <= N1 <= N/2.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, D contains the eigenvalues of the two submatrices to
+*         be combined.
+*         On exit, D contains the trailing (N-K) updated eigenvalues
+*         (those which were deflated) sorted into increasing order.
+*
+*  Q      (input/output) REAL array, dimension (LDQ, N)
+*         On entry, Q contains the eigenvectors of two submatrices in
+*         the two square blocks with corners at (1,1), (N1,N1)
+*         and (N1+1, N1+1), (N,N).
+*         On exit, Q contains the trailing (N-K) updated eigenvectors
+*         (those which were deflated) in its last N-K columns.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (input/output) INTEGER array, dimension (N)
+*         The permutation which separately sorts the two sub-problems
+*         in D into ascending order.  Note that elements in the second
+*         half of this permutation must first have N1 added to their
+*         values. Destroyed on exit.
+*
+*  RHO    (input/output) REAL
+*         On entry, the off-diagonal element associated with the rank-1
+*         cut which originally split the two submatrices which are now
+*         being recombined.
+*         On exit, RHO has been modified to the value required by
+*         SLAED3.
+*
+*  Z      (input) REAL array, dimension (N)
+*         On entry, Z contains the updating vector (the last
+*         row of the first sub-eigenvector matrix and the first row of
+*         the second sub-eigenvector matrix).
+*         On exit, the contents of Z have been destroyed by the updating
+*         process.
+*
+*  DLAMDA (output) REAL array, dimension (N)
+*         A copy of the first K eigenvalues which will be used by
+*         SLAED3 to form the secular equation.
+*
+*  W      (output) REAL array, dimension (N)
+*         The first k values of the final deflation-altered z-vector
+*         which will be passed to SLAED3.
+*
+*  Q2     (output) REAL array, dimension (N1**2+(N-N1)**2)
+*         A copy of the first K eigenvectors which will be used by
+*         SLAED3 in a matrix multiply (SGEMM) to solve for the new
+*         eigenvectors.
+*
+*  INDX   (workspace) INTEGER array, dimension (N)
+*         The permutation used to sort the contents of DLAMDA into
+*         ascending order.
+*
+*  INDXC  (output) INTEGER array, dimension (N)
+*         The permutation used to arrange the columns of the deflated
+*         Q matrix into three groups:  the first group contains non-zero
+*         elements only at and above N1, the second contains
+*         non-zero elements only below N1, and the third is dense.
+*
+*  INDXP  (workspace) INTEGER array, dimension (N)
+*         The permutation used to place deflated values of D at the end
+*         of the array.  INDXP(1:K) points to the nondeflated D-values
+*         and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+*  COLTYP (workspace/output) INTEGER array, dimension (N)
+*         During execution, a label which will indicate which of the
+*         following types a column in the Q2 matrix is:
+*         1 : non-zero in the upper half only;
+*         2 : dense;
+*         3 : non-zero in the lower half only;
+*         4 : deflated.
+*         On exit, COLTYP(i) is the number of columns of type i,
+*         for i=1 to 4 only.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               MONE, ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
+     $                   TWO = 2.0E0, EIGHT = 8.0E0 )
+*     ..
+*     .. Local Arrays ..
+      INTEGER            CTOT( 4 ), PSM( 4 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
+     $                   N2, NJ, PJ
+      REAL               C, EPS, S, T, TAU, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           ISAMAX, SLAMCH, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      N2 = N - N1
+      N1P1 = N1 + 1
+*
+      IF( RHO.LT.ZERO ) THEN
+         CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
+      END IF
+*
+*     Normalize z so that norm(z) = 1.  Since z is the concatenation of
+*     two normalized vectors, norm2(z) = sqrt(2).
+*
+      T = ONE / SQRT( TWO )
+      CALL SSCAL( N, T, Z, 1 )
+*
+*     RHO = ABS( norm(z)**2 * RHO )
+*
+      RHO = ABS( TWO*RHO )
+*
+*     Sort the eigenvalues into increasing order
+*
+      DO 10 I = N1P1, N
+         INDXQ( I ) = INDXQ( I ) + N1
+   10 CONTINUE
+*
+*     re-integrate the deflated parts from the last pass
+*
+      DO 20 I = 1, N
+         DLAMDA( I ) = D( INDXQ( I ) )
+   20 CONTINUE
+      CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
+      DO 30 I = 1, N
+         INDX( I ) = INDXQ( INDXC( I ) )
+   30 CONTINUE
+*
+*     Calculate the allowable deflation tolerance
+*
+      IMAX = ISAMAX( N, Z, 1 )
+      JMAX = ISAMAX( N, D, 1 )
+      EPS = SLAMCH( 'Epsilon' )
+      TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
+*
+*     If the rank-1 modifier is small enough, no more needs to be done
+*     except to reorganize Q so that its columns correspond with the
+*     elements in D.
+*
+      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+         K = 0
+         IQ2 = 1
+         DO 40 J = 1, N
+            I = INDX( J )
+            CALL SCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
+            DLAMDA( J ) = D( I )
+            IQ2 = IQ2 + N
+   40    CONTINUE
+         CALL SLACPY( 'A', N, N, Q2, N, Q, LDQ )
+         CALL SCOPY( N, DLAMDA, 1, D, 1 )
+         GO TO 190
+      END IF
+*
+*     If there are multiple eigenvalues then the problem deflates.  Here
+*     the number of equal eigenvalues are found.  As each equal
+*     eigenvalue is found, an elementary reflector is computed to rotate
+*     the corresponding eigensubspace so that the corresponding
+*     components of Z are zero in this new basis.
+*
+      DO 50 I = 1, N1
+         COLTYP( I ) = 1
+   50 CONTINUE
+      DO 60 I = N1P1, N
+         COLTYP( I ) = 3
+   60 CONTINUE
+*
+*
+      K = 0
+      K2 = N + 1
+      DO 70 J = 1, N
+         NJ = INDX( J )
+         IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            COLTYP( NJ ) = 4
+            INDXP( K2 ) = NJ
+            IF( J.EQ.N )
+     $         GO TO 100
+         ELSE
+            PJ = NJ
+            GO TO 80
+         END IF
+   70 CONTINUE
+   80 CONTINUE
+      J = J + 1
+      NJ = INDX( J )
+      IF( J.GT.N )
+     $   GO TO 100
+      IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         COLTYP( NJ ) = 4
+         INDXP( K2 ) = NJ
+      ELSE
+*
+*        Check if eigenvalues are close enough to allow deflation.
+*
+         S = Z( PJ )
+         C = Z( NJ )
+*
+*        Find sqrt(a**2+b**2) without overflow or
+*        destructive underflow.
+*
+         TAU = SLAPY2( C, S )
+         T = D( NJ ) - D( PJ )
+         C = C / TAU
+         S = -S / TAU
+         IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            Z( NJ ) = TAU
+            Z( PJ ) = ZERO
+            IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
+     $         COLTYP( NJ ) = 2
+            COLTYP( PJ ) = 4
+            CALL SROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
+            T = D( PJ )*C**2 + D( NJ )*S**2
+            D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
+            D( PJ ) = T
+            K2 = K2 - 1
+            I = 1
+   90       CONTINUE
+            IF( K2+I.LE.N ) THEN
+               IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
+                  INDXP( K2+I-1 ) = INDXP( K2+I )
+                  INDXP( K2+I ) = PJ
+                  I = I + 1
+                  GO TO 90
+               ELSE
+                  INDXP( K2+I-1 ) = PJ
+               END IF
+            ELSE
+               INDXP( K2+I-1 ) = PJ
+            END IF
+            PJ = NJ
+         ELSE
+            K = K + 1
+            DLAMDA( K ) = D( PJ )
+            W( K ) = Z( PJ )
+            INDXP( K ) = PJ
+            PJ = NJ
+         END IF
+      END IF
+      GO TO 80
+  100 CONTINUE
+*
+*     Record the last eigenvalue.
+*
+      K = K + 1
+      DLAMDA( K ) = D( PJ )
+      W( K ) = Z( PJ )
+      INDXP( K ) = PJ
+*
+*     Count up the total number of the various types of columns, then
+*     form a permutation which positions the four column types into
+*     four uniform groups (although one or more of these groups may be
+*     empty).
+*
+      DO 110 J = 1, 4
+         CTOT( J ) = 0
+  110 CONTINUE
+      DO 120 J = 1, N
+         CT = COLTYP( J )
+         CTOT( CT ) = CTOT( CT ) + 1
+  120 CONTINUE
+*
+*     PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+      PSM( 1 ) = 1
+      PSM( 2 ) = 1 + CTOT( 1 )
+      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+      K = N - CTOT( 4 )
+*
+*     Fill out the INDXC array so that the permutation which it induces
+*     will place all type-1 columns first, all type-2 columns next,
+*     then all type-3's, and finally all type-4's.
+*
+      DO 130 J = 1, N
+         JS = INDXP( J )
+         CT = COLTYP( JS )
+         INDX( PSM( CT ) ) = JS
+         INDXC( PSM( CT ) ) = J
+         PSM( CT ) = PSM( CT ) + 1
+  130 CONTINUE
+*
+*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+*     and Q2 respectively.  The eigenvalues/vectors which were not
+*     deflated go into the first K slots of DLAMDA and Q2 respectively,
+*     while those which were deflated go into the last N - K slots.
+*
+      I = 1
+      IQ1 = 1
+      IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
+      DO 140 J = 1, CTOT( 1 )
+         JS = INDX( I )
+         CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+         Z( I ) = D( JS )
+         I = I + 1
+         IQ1 = IQ1 + N1
+  140 CONTINUE
+*
+      DO 150 J = 1, CTOT( 2 )
+         JS = INDX( I )
+         CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+         CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+         Z( I ) = D( JS )
+         I = I + 1
+         IQ1 = IQ1 + N1
+         IQ2 = IQ2 + N2
+  150 CONTINUE
+*
+      DO 160 J = 1, CTOT( 3 )
+         JS = INDX( I )
+         CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+         Z( I ) = D( JS )
+         I = I + 1
+         IQ2 = IQ2 + N2
+  160 CONTINUE
+*
+      IQ1 = IQ2
+      DO 170 J = 1, CTOT( 4 )
+         JS = INDX( I )
+         CALL SCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
+         IQ2 = IQ2 + N
+         Z( I ) = D( JS )
+         I = I + 1
+  170 CONTINUE
+*
+*     The deflated eigenvalues and their corresponding vectors go back
+*     into the last N - K slots of D and Q respectively.
+*
+      CALL SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
+      CALL SCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
+*
+*     Copy CTOT into COLTYP for referencing in SLAED3.
+*
+      DO 180 J = 1, 4
+         COLTYP( J ) = CTOT( J )
+  180 CONTINUE
+*
+  190 CONTINUE
+      RETURN
+*
+*     End of SLAED2
+*
+      END
diff --git a/SRC/slaed3.f b/SRC/slaed3.f
new file mode 100644
index 00000000..83a56689
--- /dev/null
+++ b/SRC/slaed3.f
@@ -0,0 +1,264 @@
+      SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
+     $                   CTOT, W, S, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDQ, N, N1
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            CTOT( * ), INDX( * )
+      REAL               D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+     $                   S( * ), W( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED3 finds the roots of the secular equation, as defined by the
+*  values in D, W, and RHO, between 1 and K.  It makes the
+*  appropriate calls to SLAED4 and then updates the eigenvectors by
+*  multiplying the matrix of eigenvectors of the pair of eigensystems
+*  being combined by the matrix of eigenvectors of the K-by-K system
+*  which is solved here.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  K       (input) INTEGER
+*          The number of terms in the rational function to be solved by
+*          SLAED4.  K >= 0.
+*
+*  N       (input) INTEGER
+*          The number of rows and columns in the Q matrix.
+*          N >= K (deflation may result in N>K).
+*
+*  N1      (input) INTEGER
+*          The location of the last eigenvalue in the leading submatrix.
+*          min(1,N) <= N1 <= N/2.
+*
+*  D       (output) REAL array, dimension (N)
+*          D(I) contains the updated eigenvalues for
+*          1 <= I <= K.
+*
+*  Q       (output) REAL array, dimension (LDQ,N)
+*          Initially the first K columns are used as workspace.
+*          On output the columns 1 to K contain
+*          the updated eigenvectors.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  RHO     (input) REAL
+*          The value of the parameter in the rank one update equation.
+*          RHO >= 0 required.
+*
+*  DLAMDA  (input/output) REAL array, dimension (K)
+*          The first K elements of this array contain the old roots
+*          of the deflated updating problem.  These are the poles
+*          of the secular equation. May be changed on output by
+*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
+*          Cray-2, or Cray C-90, as described above.
+*
+*  Q2      (input) REAL array, dimension (LDQ2, N)
+*          The first K columns of this matrix contain the non-deflated
+*          eigenvectors for the split problem.
+*
+*  INDX    (input) INTEGER array, dimension (N)
+*          The permutation used to arrange the columns of the deflated
+*          Q matrix into three groups (see SLAED2).
+*          The rows of the eigenvectors found by SLAED4 must be likewise
+*          permuted before the matrix multiply can take place.
+*
+*  CTOT    (input) INTEGER array, dimension (4)
+*          A count of the total number of the various types of columns
+*          in Q, as described in INDX.  The fourth column type is any
+*          column which has been deflated.
+*
+*  W       (input/output) REAL array, dimension (K)
+*          The first K elements of this array contain the components
+*          of the deflation-adjusted updating vector. Destroyed on
+*          output.
+*
+*  S       (workspace) REAL array, dimension (N1 + 1)*K
+*          Will contain the eigenvectors of the repaired matrix which
+*          will be multiplied by the previously accumulated eigenvectors
+*          to update the system.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of S.  LDS >= max(1,K).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, IQ2, J, N12, N2, N23
+      REAL               TEMP
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3, SNRM2
+      EXTERNAL           SLAMC3, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, SLACPY, SLAED4, SLASET, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( K.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.K ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED3', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 )
+     $   RETURN
+*
+*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DLAMDA(I) if it is 1; this makes the subsequent
+*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DLAMDA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DLAMDA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 10 I = 1, K
+         DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+   10 CONTINUE
+*
+      DO 20 J = 1, K
+         CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+*        If the zero finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 )
+     $      GO TO 120
+   20 CONTINUE
+*
+      IF( K.EQ.1 )
+     $   GO TO 110
+      IF( K.EQ.2 ) THEN
+         DO 30 J = 1, K
+            W( 1 ) = Q( 1, J )
+            W( 2 ) = Q( 2, J )
+            II = INDX( 1 )
+            Q( 1, J ) = W( II )
+            II = INDX( 2 )
+            Q( 2, J ) = W( II )
+   30    CONTINUE
+         GO TO 110
+      END IF
+*
+*     Compute updated W.
+*
+      CALL SCOPY( K, W, 1, S, 1 )
+*
+*     Initialize W(I) = Q(I,I)
+*
+      CALL SCOPY( K, Q, LDQ+1, W, 1 )
+      DO 60 J = 1, K
+         DO 40 I = 1, J - 1
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   40    CONTINUE
+         DO 50 I = J + 1, K
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   50    CONTINUE
+   60 CONTINUE
+      DO 70 I = 1, K
+         W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
+   70 CONTINUE
+*
+*     Compute eigenvectors of the modified rank-1 modification.
+*
+      DO 100 J = 1, K
+         DO 80 I = 1, K
+            S( I ) = W( I ) / Q( I, J )
+   80    CONTINUE
+         TEMP = SNRM2( K, S, 1 )
+         DO 90 I = 1, K
+            II = INDX( I )
+            Q( I, J ) = S( II ) / TEMP
+   90    CONTINUE
+  100 CONTINUE
+*
+*     Compute the updated eigenvectors.
+*
+  110 CONTINUE
+*
+      N2 = N - N1
+      N12 = CTOT( 1 ) + CTOT( 2 )
+      N23 = CTOT( 2 ) + CTOT( 3 )
+*
+      CALL SLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
+      IQ2 = N1*N12 + 1
+      IF( N23.NE.0 ) THEN
+         CALL SGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
+     $               ZERO, Q( N1+1, 1 ), LDQ )
+      ELSE
+         CALL SLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
+      END IF
+*
+      CALL SLACPY( 'A', N12, K, Q, LDQ, S, N12 )
+      IF( N12.NE.0 ) THEN
+         CALL SGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
+     $               LDQ )
+      ELSE
+         CALL SLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
+      END IF
+*
+*
+  120 CONTINUE
+      RETURN
+*
+*     End of SLAED3
+*
+      END
diff --git a/SRC/slaed4.f b/SRC/slaed4.f
new file mode 100644
index 00000000..dbb1e202
--- /dev/null
+++ b/SRC/slaed4.f
@@ -0,0 +1,844 @@
+      SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I, INFO, N
+      REAL               DLAM, RHO
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), DELTA( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the I-th updated eigenvalue of a symmetric
+*  rank-one modification to a diagonal matrix whose elements are
+*  given in the array d, and that
+*
+*             D(i) < D(j)  for  i < j
+*
+*  and that RHO > 0.  This is arranged by the calling routine, and is
+*  no loss in generality.  The rank-one modified system is thus
+*
+*             diag( D )  +  RHO *  Z * Z_transpose.
+*
+*  where we assume the Euclidean norm of Z is 1.
+*
+*  The method consists of approximating the rational functions in the
+*  secular equation by simpler interpolating rational functions.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The length of all arrays.
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  1 <= I <= N.
+*
+*  D      (input) REAL array, dimension (N)
+*         The original eigenvalues.  It is assumed that they are in
+*         order, D(I) < D(J)  for I < J.
+*
+*  Z      (input) REAL array, dimension (N)
+*         The components of the updating vector.
+*
+*  DELTA  (output) REAL array, dimension (N)
+*         If N .GT. 2, DELTA contains (D(j) - lambda_I) in its  j-th
+*         component.  If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5
+*         for detail. The vector DELTA contains the information necessary
+*         to construct the eigenvectors by SLAED3 and SLAED9.
+*
+*  RHO    (input) REAL
+*         The scalar in the symmetric updating formula.
+*
+*  DLAM   (output) REAL
+*         The computed lambda_I, the I-th updated eigenvalue.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit
+*         > 0:  if INFO = 1, the updating process failed.
+*
+*  Internal Parameters
+*  ===================
+*
+*  Logical variable ORGATI (origin-at-i?) is used for distinguishing
+*  whether D(i) or D(i+1) is treated as the origin.
+*
+*            ORGATI = .true.    origin at i
+*            ORGATI = .false.   origin at i+1
+*
+*   Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+*   if we are working with THREE poles!
+*
+*   MAXIT is the maximum number of iterations allowed for each
+*   eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 30 )
+      REAL               ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0,
+     $                   TEN = 10.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ORGATI, SWTCH, SWTCH3
+      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
+      REAL               A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
+     $                   EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
+     $                   RHOINV, TAU, TEMP, TEMP1, W
+*     ..
+*     .. Local Arrays ..
+      REAL               ZZ( 3 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAED5, SLAED6
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Since this routine is called in an inner loop, we do no argument
+*     checking.
+*
+*     Quick return for N=1 and 2.
+*
+      INFO = 0
+      IF( N.EQ.1 ) THEN
+*
+*         Presumably, I=1 upon entry
+*
+         DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
+         DELTA( 1 ) = ONE
+         RETURN
+      END IF
+      IF( N.EQ.2 ) THEN
+         CALL SLAED5( I, D, Z, DELTA, RHO, DLAM )
+         RETURN
+      END IF
+*
+*     Compute machine epsilon
+*
+      EPS = SLAMCH( 'Epsilon' )
+      RHOINV = ONE / RHO
+*
+*     The case I = N
+*
+      IF( I.EQ.N ) THEN
+*
+*        Initialize some basic variables
+*
+         II = N - 1
+         NITER = 1
+*
+*        Calculate initial guess
+*
+         MIDPT = RHO / TWO
+*
+*        If ||Z||_2 is not one, then TEMP should be set to
+*        RHO * ||Z||_2^2 / TWO
+*
+         DO 10 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+   10    CONTINUE
+*
+         PSI = ZERO
+         DO 20 J = 1, N - 2
+            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+   20    CONTINUE
+*
+         C = RHOINV + PSI
+         W = C + Z( II )*Z( II ) / DELTA( II ) +
+     $       Z( N )*Z( N ) / DELTA( N )
+*
+         IF( W.LE.ZERO ) THEN
+            TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
+     $             Z( N )*Z( N ) / RHO
+            IF( C.LE.TEMP ) THEN
+               TAU = RHO
+            ELSE
+               DEL = D( N ) - D( N-1 )
+               A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+               B = Z( N )*Z( N )*DEL
+               IF( A.LT.ZERO ) THEN
+                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+               ELSE
+                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+               END IF
+            END IF
+*
+*           It can be proved that
+*               D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
+*
+            DLTLB = MIDPT
+            DLTUB = RHO
+         ELSE
+            DEL = D( N ) - D( N-1 )
+            A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+            B = Z( N )*Z( N )*DEL
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+            ELSE
+               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+            END IF
+*
+*           It can be proved that
+*               D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
+*
+            DLTLB = ZERO
+            DLTUB = MIDPT
+         END IF
+*
+         DO 30 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - TAU
+   30    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 40 J = 1, II
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   40    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / DELTA( N )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            DLAM = D( I ) + TAU
+            GO TO 250
+         END IF
+*
+         IF( W.LE.ZERO ) THEN
+            DLTLB = MAX( DLTLB, TAU )
+         ELSE
+            DLTUB = MIN( DLTUB, TAU )
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+         A = ( DELTA( N-1 )+DELTA( N ) )*W -
+     $       DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+         B = DELTA( N-1 )*DELTA( N )*W
+         IF( C.LT.ZERO )
+     $      C = ABS( C )
+         IF( C.EQ.ZERO ) THEN
+*          ETA = B/A
+*           ETA = RHO - TAU
+            ETA = DLTUB - TAU
+         ELSE IF( A.GE.ZERO ) THEN
+            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GT.ZERO )
+     $      ETA = -W / ( DPSI+DPHI )
+         TEMP = TAU + ETA
+         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+            IF( W.LT.ZERO ) THEN
+               ETA = ( DLTUB-TAU ) / TWO
+            ELSE
+               ETA = ( DLTLB-TAU ) / TWO
+            END IF
+         END IF
+         DO 50 J = 1, N
+            DELTA( J ) = DELTA( J ) - ETA
+   50    CONTINUE
+*
+         TAU = TAU + ETA
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 60 J = 1, II
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   60    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / DELTA( N )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Main loop to update the values of the array   DELTA
+*
+         ITER = NITER + 1
+*
+         DO 90 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               DLAM = D( I ) + TAU
+               GO TO 250
+            END IF
+*
+            IF( W.LE.ZERO ) THEN
+               DLTLB = MAX( DLTLB, TAU )
+            ELSE
+               DLTUB = MIN( DLTUB, TAU )
+            END IF
+*
+*           Calculate the new step
+*
+            C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+            A = ( DELTA( N-1 )+DELTA( N ) )*W -
+     $          DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+            B = DELTA( N-1 )*DELTA( N )*W
+            IF( A.GE.ZERO ) THEN
+               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GT.ZERO )
+     $         ETA = -W / ( DPSI+DPHI )
+            TEMP = TAU + ETA
+            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+               IF( W.LT.ZERO ) THEN
+                  ETA = ( DLTUB-TAU ) / TWO
+               ELSE
+                  ETA = ( DLTLB-TAU ) / TWO
+               END IF
+            END IF
+            DO 70 J = 1, N
+               DELTA( J ) = DELTA( J ) - ETA
+   70       CONTINUE
+*
+            TAU = TAU + ETA
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 80 J = 1, II
+               TEMP = Z( J ) / DELTA( J )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+   80       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            TEMP = Z( N ) / DELTA( N )
+            PHI = Z( N )*TEMP
+            DPHI = TEMP*TEMP
+            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $               ABS( TAU )*( DPSI+DPHI )
+*
+            W = RHOINV + PHI + PSI
+   90    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+         DLAM = D( I ) + TAU
+         GO TO 250
+*
+*        End for the case I = N
+*
+      ELSE
+*
+*        The case for I < N
+*
+         NITER = 1
+         IP1 = I + 1
+*
+*        Calculate initial guess
+*
+         DEL = D( IP1 ) - D( I )
+         MIDPT = DEL / TWO
+         DO 100 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+  100    CONTINUE
+*
+         PSI = ZERO
+         DO 110 J = 1, I - 1
+            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+  110    CONTINUE
+*
+         PHI = ZERO
+         DO 120 J = N, I + 2, -1
+            PHI = PHI + Z( J )*Z( J ) / DELTA( J )
+  120    CONTINUE
+         C = RHOINV + PSI + PHI
+         W = C + Z( I )*Z( I ) / DELTA( I ) +
+     $       Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
+*
+         IF( W.GT.ZERO ) THEN
+*
+*           d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
+*
+*           We choose d(i) as origin.
+*
+            ORGATI = .TRUE.
+            A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+            B = Z( I )*Z( I )*DEL
+            IF( A.GT.ZERO ) THEN
+               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            ELSE
+               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+            DLTLB = ZERO
+            DLTUB = MIDPT
+         ELSE
+*
+*           (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
+*
+*           We choose d(i+1) as origin.
+*
+            ORGATI = .FALSE.
+            A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+            B = Z( IP1 )*Z( IP1 )*DEL
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+            ELSE
+               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+            DLTLB = -MIDPT
+            DLTUB = ZERO
+         END IF
+*
+         IF( ORGATI ) THEN
+            DO 130 J = 1, N
+               DELTA( J ) = ( D( J )-D( I ) ) - TAU
+  130       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
+  140       CONTINUE
+         END IF
+         IF( ORGATI ) THEN
+            II = I
+         ELSE
+            II = I + 1
+         END IF
+         IIM1 = II - 1
+         IIP1 = II + 1
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 150 J = 1, IIM1
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  150    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 160 J = N, IIP1, -1
+            TEMP = Z( J ) / DELTA( J )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  160    CONTINUE
+*
+         W = RHOINV + PHI + PSI
+*
+*        W is the value of the secular function with
+*        its ii-th element removed.
+*
+         SWTCH3 = .FALSE.
+         IF( ORGATI ) THEN
+            IF( W.LT.ZERO )
+     $         SWTCH3 = .TRUE.
+         ELSE
+            IF( W.GT.ZERO )
+     $         SWTCH3 = .TRUE.
+         END IF
+         IF( II.EQ.1 .OR. II.EQ.N )
+     $      SWTCH3 = .FALSE.
+*
+         TEMP = Z( II ) / DELTA( II )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = W + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            IF( ORGATI ) THEN
+               DLAM = D( I ) + TAU
+            ELSE
+               DLAM = D( IP1 ) + TAU
+            END IF
+            GO TO 250
+         END IF
+*
+         IF( W.LE.ZERO ) THEN
+            DLTLB = MAX( DLTLB, TAU )
+         ELSE
+            DLTUB = MIN( DLTUB, TAU )
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         IF( .NOT.SWTCH3 ) THEN
+            IF( ORGATI ) THEN
+               C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
+     $             ( Z( I ) / DELTA( I ) )**2
+            ELSE
+               C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+     $             ( Z( IP1 ) / DELTA( IP1 ) )**2
+            END IF
+            A = ( DELTA( I )+DELTA( IP1 ) )*W -
+     $          DELTA( I )*DELTA( IP1 )*DW
+            B = DELTA( I )*DELTA( IP1 )*W
+            IF( C.EQ.ZERO ) THEN
+               IF( A.EQ.ZERO ) THEN
+                  IF( ORGATI ) THEN
+                     A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
+     $                   ( DPSI+DPHI )
+                  ELSE
+                     A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
+     $                   ( DPSI+DPHI )
+                  END IF
+               END IF
+               ETA = B / A
+            ELSE IF( A.LE.ZERO ) THEN
+               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+         ELSE
+*
+*           Interpolation using THREE most relevant poles
+*
+            TEMP = RHOINV + PSI + PHI
+            IF( ORGATI ) THEN
+               TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+               TEMP1 = TEMP1*TEMP1
+               C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+     $             ( D( IIM1 )-D( IIP1 ) )*TEMP1
+               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+               ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+     $                   ( ( DPSI-TEMP1 )+DPHI )
+            ELSE
+               TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+               TEMP1 = TEMP1*TEMP1
+               C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+     $             ( D( IIP1 )-D( IIM1 ) )*TEMP1
+               ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+     $                   ( DPSI+( DPHI-TEMP1 ) )
+               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+            END IF
+            ZZ( 2 ) = Z( II )*Z( II )
+            CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+     $                   INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 250
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GE.ZERO )
+     $      ETA = -W / DW
+         TEMP = TAU + ETA
+         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+            IF( W.LT.ZERO ) THEN
+               ETA = ( DLTUB-TAU ) / TWO
+            ELSE
+               ETA = ( DLTLB-TAU ) / TWO
+            END IF
+         END IF
+*
+         PREW = W
+*
+         DO 180 J = 1, N
+            DELTA( J ) = DELTA( J ) - ETA
+  180    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 190 J = 1, IIM1
+            TEMP = Z( J ) / DELTA( J )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  190    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 200 J = N, IIP1, -1
+            TEMP = Z( J ) / DELTA( J )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  200    CONTINUE
+*
+         TEMP = Z( II ) / DELTA( II )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = RHOINV + PHI + PSI + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
+*
+         SWTCH = .FALSE.
+         IF( ORGATI ) THEN
+            IF( -W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         ELSE
+            IF( W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         END IF
+*
+         TAU = TAU + ETA
+*
+*        Main loop to update the values of the array   DELTA
+*
+         ITER = NITER + 1
+*
+         DO 240 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               IF( ORGATI ) THEN
+                  DLAM = D( I ) + TAU
+               ELSE
+                  DLAM = D( IP1 ) + TAU
+               END IF
+               GO TO 250
+            END IF
+*
+            IF( W.LE.ZERO ) THEN
+               DLTLB = MAX( DLTLB, TAU )
+            ELSE
+               DLTUB = MIN( DLTUB, TAU )
+            END IF
+*
+*           Calculate the new step
+*
+            IF( .NOT.SWTCH3 ) THEN
+               IF( .NOT.SWTCH ) THEN
+                  IF( ORGATI ) THEN
+                     C = W - DELTA( IP1 )*DW -
+     $                   ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
+                  ELSE
+                     C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+     $                   ( Z( IP1 ) / DELTA( IP1 ) )**2
+                  END IF
+               ELSE
+                  TEMP = Z( II ) / DELTA( II )
+                  IF( ORGATI ) THEN
+                     DPSI = DPSI + TEMP*TEMP
+                  ELSE
+                     DPHI = DPHI + TEMP*TEMP
+                  END IF
+                  C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
+               END IF
+               A = ( DELTA( I )+DELTA( IP1 ) )*W -
+     $             DELTA( I )*DELTA( IP1 )*DW
+               B = DELTA( I )*DELTA( IP1 )*W
+               IF( C.EQ.ZERO ) THEN
+                  IF( A.EQ.ZERO ) THEN
+                     IF( .NOT.SWTCH ) THEN
+                        IF( ORGATI ) THEN
+                           A = Z( I )*Z( I ) + DELTA( IP1 )*
+     $                         DELTA( IP1 )*( DPSI+DPHI )
+                        ELSE
+                           A = Z( IP1 )*Z( IP1 ) +
+     $                         DELTA( I )*DELTA( I )*( DPSI+DPHI )
+                        END IF
+                     ELSE
+                        A = DELTA( I )*DELTA( I )*DPSI +
+     $                      DELTA( IP1 )*DELTA( IP1 )*DPHI
+                     END IF
+                  END IF
+                  ETA = B / A
+               ELSE IF( A.LE.ZERO ) THEN
+                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+               ELSE
+                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+               END IF
+            ELSE
+*
+*              Interpolation using THREE most relevant poles
+*
+               TEMP = RHOINV + PSI + PHI
+               IF( SWTCH ) THEN
+                  C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
+                  ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
+                  ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
+               ELSE
+                  IF( ORGATI ) THEN
+                     TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+                     TEMP1 = TEMP1*TEMP1
+                     C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+     $                   ( D( IIM1 )-D( IIP1 ) )*TEMP1
+                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+                     ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+     $                         ( ( DPSI-TEMP1 )+DPHI )
+                  ELSE
+                     TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+                     TEMP1 = TEMP1*TEMP1
+                     C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+     $                   ( D( IIP1 )-D( IIM1 ) )*TEMP1
+                     ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+     $                         ( DPSI+( DPHI-TEMP1 ) )
+                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+                  END IF
+               END IF
+               CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+     $                      INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 250
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GE.ZERO )
+     $         ETA = -W / DW
+            TEMP = TAU + ETA
+            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+               IF( W.LT.ZERO ) THEN
+                  ETA = ( DLTUB-TAU ) / TWO
+               ELSE
+                  ETA = ( DLTLB-TAU ) / TWO
+               END IF
+            END IF
+*
+            DO 210 J = 1, N
+               DELTA( J ) = DELTA( J ) - ETA
+  210       CONTINUE
+*
+            TAU = TAU + ETA
+            PREW = W
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 220 J = 1, IIM1
+               TEMP = Z( J ) / DELTA( J )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+  220       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            DPHI = ZERO
+            PHI = ZERO
+            DO 230 J = N, IIP1, -1
+               TEMP = Z( J ) / DELTA( J )
+               PHI = PHI + Z( J )*TEMP
+               DPHI = DPHI + TEMP*TEMP
+               ERRETM = ERRETM + PHI
+  230       CONTINUE
+*
+            TEMP = Z( II ) / DELTA( II )
+            DW = DPSI + DPHI + TEMP*TEMP
+            TEMP = Z( II )*TEMP
+            W = RHOINV + PHI + PSI + TEMP
+            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $               THREE*ABS( TEMP ) + ABS( TAU )*DW
+            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+     $         SWTCH = .NOT.SWTCH
+*
+  240    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+         IF( ORGATI ) THEN
+            DLAM = D( I ) + TAU
+         ELSE
+            DLAM = D( IP1 ) + TAU
+         END IF
+*
+      END IF
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of SLAED4
+*
+      END
diff --git a/SRC/slaed5.f b/SRC/slaed5.f
new file mode 100644
index 00000000..20332b8d
--- /dev/null
+++ b/SRC/slaed5.f
@@ -0,0 +1,124 @@
+      SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I
+      REAL               DLAM, RHO
+*     ..
+*     .. Array Arguments ..
+      REAL               D( 2 ), DELTA( 2 ), Z( 2 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the I-th eigenvalue of a symmetric rank-one
+*  modification of a 2-by-2 diagonal matrix
+*
+*             diag( D )  +  RHO *  Z * transpose(Z) .
+*
+*  The diagonal elements in the array D are assumed to satisfy
+*
+*             D(i) < D(j)  for  i < j .
+*
+*  We also assume RHO > 0 and that the Euclidean norm of the vector
+*  Z is one.
+*
+*  Arguments
+*  =========
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  I = 1 or I = 2.
+*
+*  D      (input) REAL array, dimension (2)
+*         The original eigenvalues.  We assume D(1) < D(2).
+*
+*  Z      (input) REAL array, dimension (2)
+*         The components of the updating vector.
+*
+*  DELTA  (output) REAL array, dimension (2)
+*         The vector DELTA contains the information necessary
+*         to construct the eigenvectors.
+*
+*  RHO    (input) REAL
+*         The scalar in the symmetric updating formula.
+*
+*  DLAM   (output) REAL
+*         The computed lambda_I, the I-th updated eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, FOUR
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   FOUR = 4.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               B, C, DEL, TAU, TEMP, W
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      DEL = D( 2 ) - D( 1 )
+      IF( I.EQ.1 ) THEN
+         W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
+         IF( W.GT.ZERO ) THEN
+            B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 1 )*Z( 1 )*DEL
+*
+*           B > ZERO, always
+*
+            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+            DLAM = D( 1 ) + TAU
+            DELTA( 1 ) = -Z( 1 ) / TAU
+            DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+         ELSE
+            B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 2 )*Z( 2 )*DEL
+            IF( B.GT.ZERO ) THEN
+               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+            ELSE
+               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+            END IF
+            DLAM = D( 2 ) + TAU
+            DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+            DELTA( 2 ) = -Z( 2 ) / TAU
+         END IF
+         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+         DELTA( 1 ) = DELTA( 1 ) / TEMP
+         DELTA( 2 ) = DELTA( 2 ) / TEMP
+      ELSE
+*
+*     Now I=2
+*
+         B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+         C = RHO*Z( 2 )*Z( 2 )*DEL
+         IF( B.GT.ZERO ) THEN
+            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+         ELSE
+            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+         END IF
+         DLAM = D( 2 ) + TAU
+         DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+         DELTA( 2 ) = -Z( 2 ) / TAU
+         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+         DELTA( 1 ) = DELTA( 1 ) / TEMP
+         DELTA( 2 ) = DELTA( 2 ) / TEMP
+      END IF
+      RETURN
+*
+*     End OF SLAED5
+*
+      END
diff --git a/SRC/slaed6.f b/SRC/slaed6.f
new file mode 100644
index 00000000..03464628
--- /dev/null
+++ b/SRC/slaed6.f
@@ -0,0 +1,327 @@
+      SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     February 2007
+*
+*     .. Scalar Arguments ..
+      LOGICAL            ORGATI
+      INTEGER            INFO, KNITER
+      REAL               FINIT, RHO, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               D( 3 ), Z( 3 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED6 computes the positive or negative root (closest to the origin)
+*  of
+*                   z(1)        z(2)        z(3)
+*  f(x) =   rho + --------- + ---------- + ---------
+*                  d(1)-x      d(2)-x      d(3)-x
+*
+*  It is assumed that
+*
+*        if ORGATI = .true. the root is between d(2) and d(3);
+*        otherwise it is between d(1) and d(2)
+*
+*  This routine will be called by SLAED4 when necessary. In most cases,
+*  the root sought is the smallest in magnitude, though it might not be
+*  in some extremely rare situations.
+*
+*  Arguments
+*  =========
+*
+*  KNITER       (input) INTEGER
+*               Refer to SLAED4 for its significance.
+*
+*  ORGATI       (input) LOGICAL
+*               If ORGATI is true, the needed root is between d(2) and
+*               d(3); otherwise it is between d(1) and d(2).  See
+*               SLAED4 for further details.
+*
+*  RHO          (input) REAL            
+*               Refer to the equation f(x) above.
+*
+*  D            (input) REAL array, dimension (3)
+*               D satisfies d(1) < d(2) < d(3).
+*
+*  Z            (input) REAL array, dimension (3)
+*               Each of the elements in z must be positive.
+*
+*  FINIT        (input) REAL            
+*               The value of f at 0. It is more accurate than the one
+*               evaluated inside this routine (if someone wants to do
+*               so).
+*
+*  TAU          (output) REAL            
+*               The root of the equation f(x).
+*
+*  INFO         (output) INTEGER
+*               = 0: successful exit
+*               > 0: if INFO = 1, failure to converge
+*
+*  Further Details
+*  ===============
+*
+*  30/06/99: Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  10/02/03: This version has a few statements commented out for thread safety
+*     (machine parameters are computed on each entry). SJH.
+*
+*  05/10/06: Modified from a new version of Ren-Cang Li, use
+*     Gragg-Thornton-Warner cubic convergent scheme for better stability.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 40 )
+      REAL               ZERO, ONE, TWO, THREE, FOUR, EIGHT
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Local Arrays ..
+      REAL               DSCALE( 3 ), ZSCALE( 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SCALE
+      INTEGER            I, ITER, NITER
+      REAL               A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
+     $                   FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
+     $                   SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, 
+     $                   LBD, UBD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+      IF( ORGATI ) THEN
+         LBD = D(2)
+         UBD = D(3)
+      ELSE
+         LBD = D(1)
+         UBD = D(2)
+      END IF
+      IF( FINIT .LT. ZERO )THEN
+         LBD = ZERO
+      ELSE
+         UBD = ZERO 
+      END IF
+*
+      NITER = 1
+      TAU = ZERO
+      IF( KNITER.EQ.2 ) THEN
+         IF( ORGATI ) THEN
+            TEMP = ( D( 3 )-D( 2 ) ) / TWO
+            C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
+            A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
+            B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
+         ELSE
+            TEMP = ( D( 1 )-D( 2 ) ) / TWO
+            C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
+            A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
+            B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
+         END IF
+         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+         A = A / TEMP
+         B = B / TEMP
+         C = C / TEMP
+         IF( C.EQ.ZERO ) THEN
+            TAU = B / A
+         ELSE IF( A.LE.ZERO ) THEN
+            TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+         IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+     $      TAU = ( LBD+UBD )/TWO
+         IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
+            TAU = ZERO
+         ELSE
+            TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
+     $                     TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
+     $                     TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
+            IF( TEMP .LE. ZERO )THEN
+               LBD = TAU
+            ELSE
+               UBD = TAU
+            END IF
+            IF( ABS( FINIT ).LE.ABS( TEMP ) )
+     $         TAU = ZERO
+         END IF
+      END IF
+*
+*     get machine parameters for possible scaling to avoid overflow
+*
+*     modified by Sven: parameters SMALL1, SMINV1, SMALL2,
+*     SMINV2, EPS are not SAVEd anymore between one call to the
+*     others but recomputed at each call
+*
+      EPS = SLAMCH( 'Epsilon' )
+      BASE = SLAMCH( 'Base' )
+      SMALL1 = BASE**( INT( LOG( SLAMCH( 'SafMin' ) ) / LOG( BASE ) /
+     $         THREE ) )
+      SMINV1 = ONE / SMALL1
+      SMALL2 = SMALL1*SMALL1
+      SMINV2 = SMINV1*SMINV1
+*
+*     Determine if scaling of inputs necessary to avoid overflow
+*     when computing 1/TEMP**3
+*
+      IF( ORGATI ) THEN
+         TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
+      ELSE
+         TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
+      END IF
+      SCALE = .FALSE.
+      IF( TEMP.LE.SMALL1 ) THEN
+         SCALE = .TRUE.
+         IF( TEMP.LE.SMALL2 ) THEN
+*
+*        Scale up by power of radix nearest 1/SAFMIN**(2/3)
+*
+            SCLFAC = SMINV2
+            SCLINV = SMALL2
+         ELSE
+*
+*        Scale up by power of radix nearest 1/SAFMIN**(1/3)
+*
+            SCLFAC = SMINV1
+            SCLINV = SMALL1
+         END IF
+*
+*        Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
+*
+         DO 10 I = 1, 3
+            DSCALE( I ) = D( I )*SCLFAC
+            ZSCALE( I ) = Z( I )*SCLFAC
+   10    CONTINUE
+         TAU = TAU*SCLFAC
+         LBD = LBD*SCLFAC
+         UBD = UBD*SCLFAC
+      ELSE
+*
+*        Copy D and Z to DSCALE and ZSCALE
+*
+         DO 20 I = 1, 3
+            DSCALE( I ) = D( I )
+            ZSCALE( I ) = Z( I )
+   20    CONTINUE
+      END IF
+*
+      FC = ZERO
+      DF = ZERO
+      DDF = ZERO
+      DO 30 I = 1, 3
+         TEMP = ONE / ( DSCALE( I )-TAU )
+         TEMP1 = ZSCALE( I )*TEMP
+         TEMP2 = TEMP1*TEMP
+         TEMP3 = TEMP2*TEMP
+         FC = FC + TEMP1 / DSCALE( I )
+         DF = DF + TEMP2
+         DDF = DDF + TEMP3
+   30 CONTINUE
+      F = FINIT + TAU*FC
+*
+      IF( ABS( F ).LE.ZERO )
+     $   GO TO 60
+      IF( F .LE. ZERO )THEN
+         LBD = TAU
+      ELSE
+         UBD = TAU
+      END IF
+*
+*        Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
+*                            scheme
+*
+*     It is not hard to see that
+*
+*           1) Iterations will go up monotonically
+*              if FINIT < 0;
+*
+*           2) Iterations will go down monotonically
+*              if FINIT > 0.
+*
+      ITER = NITER + 1
+*
+      DO 50 NITER = ITER, MAXIT
+*
+         IF( ORGATI ) THEN
+            TEMP1 = DSCALE( 2 ) - TAU
+            TEMP2 = DSCALE( 3 ) - TAU
+         ELSE
+            TEMP1 = DSCALE( 1 ) - TAU
+            TEMP2 = DSCALE( 2 ) - TAU
+         END IF
+         A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
+         B = TEMP1*TEMP2*F
+         C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
+         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+         A = A / TEMP
+         B = B / TEMP
+         C = C / TEMP
+         IF( C.EQ.ZERO ) THEN
+            ETA = B / A
+         ELSE IF( A.LE.ZERO ) THEN
+            ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+         IF( F*ETA.GE.ZERO ) THEN
+            ETA = -F / DF
+         END IF
+*
+         TAU = TAU + ETA
+         IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+     $      TAU = ( LBD + UBD )/TWO 
+*
+         FC = ZERO
+         ERRETM = ZERO
+         DF = ZERO
+         DDF = ZERO
+         DO 40 I = 1, 3
+            TEMP = ONE / ( DSCALE( I )-TAU )
+            TEMP1 = ZSCALE( I )*TEMP
+            TEMP2 = TEMP1*TEMP
+            TEMP3 = TEMP2*TEMP
+            TEMP4 = TEMP1 / DSCALE( I )
+            FC = FC + TEMP4
+            ERRETM = ERRETM + ABS( TEMP4 )
+            DF = DF + TEMP2
+            DDF = DDF + TEMP3
+   40    CONTINUE
+         F = FINIT + TAU*FC
+         ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
+     $            ABS( TAU )*DF
+         IF( ABS( F ).LE.EPS*ERRETM )
+     $      GO TO 60
+         IF( F .LE. ZERO )THEN
+            LBD = TAU
+         ELSE
+            UBD = TAU
+         END IF
+   50 CONTINUE
+      INFO = 1
+   60 CONTINUE
+*
+*     Undo scaling
+*
+      IF( SCALE )
+     $   TAU = TAU*SCLINV
+      RETURN
+*
+*     End of SLAED6
+*
+      END
diff --git a/SRC/slaed7.f b/SRC/slaed7.f
new file mode 100644
index 00000000..f8979c80
--- /dev/null
+++ b/SRC/slaed7.f
@@ -0,0 +1,287 @@
+      SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
+     $                   LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
+     $                   PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
+     $                   QSIZ, TLVLS
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
+     $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
+      REAL               D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
+     $                   QSTORE( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED7 computes the updated eigensystem of a diagonal
+*  matrix after modification by a rank-one symmetric matrix. This
+*  routine is used only for the eigenproblem which requires all
+*  eigenvalues and optionally eigenvectors of a dense symmetric matrix
+*  that has been reduced to tridiagonal form.  SLAED1 handles
+*  the case in which all eigenvalues and eigenvectors of a symmetric
+*  tridiagonal matrix are desired.
+*
+*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+*     where Z = Q'u, u is a vector of length N with ones in the
+*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+*     The eigenvectors of the original matrix are stored in Q, and the
+*     eigenvalues are in D.  The algorithm consists of three stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple eigenvalues or if there is a zero in
+*        the Z vector.  For each such occurence the dimension of the
+*        secular equation problem is reduced by one.  This stage is
+*        performed by the routine SLAED8.
+*
+*        The second stage consists of calculating the updated
+*        eigenvalues. This is done by finding the roots of the secular
+*        equation via the routine SLAED4 (as called by SLAED9).
+*        This routine also calculates the eigenvectors of the current
+*        problem.
+*
+*        The final stage consists of computing the updated eigenvectors
+*        directly using the updated eigenvalues.  The eigenvectors for
+*        the current problem are multiplied with the eigenvectors from
+*        the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          = 0:  Compute eigenvalues only.
+*          = 1:  Compute eigenvectors of original dense symmetric matrix
+*                also.  On entry, Q contains the orthogonal matrix used
+*                to reduce the original matrix to tridiagonal form.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the orthogonal matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  TLVLS  (input) INTEGER
+*         The total number of merging levels in the overall divide and
+*         conquer tree.
+*
+*  CURLVL (input) INTEGER
+*         The current level in the overall merge routine,
+*         0 <= CURLVL <= TLVLS.
+*
+*  CURPBM (input) INTEGER
+*         The current problem in the current level in the overall
+*         merge routine (counting from upper left to lower right).
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, the eigenvalues of the rank-1-perturbed matrix.
+*         On exit, the eigenvalues of the repaired matrix.
+*
+*  Q      (input/output) REAL array, dimension (LDQ, N)
+*         On entry, the eigenvectors of the rank-1-perturbed matrix.
+*         On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (output) INTEGER array, dimension (N)
+*         The permutation which will reintegrate the subproblem just
+*         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
+*         will be in ascending order.
+*
+*  RHO    (input) REAL
+*         The subdiagonal element used to create the rank-1
+*         modification.
+*
+*  CUTPNT (input) INTEGER
+*         Contains the location of the last eigenvalue in the leading
+*         sub-matrix.  min(1,N) <= CUTPNT <= N.
+*
+*  QSTORE (input/output) REAL array, dimension (N**2+1)
+*         Stores eigenvectors of submatrices encountered during
+*         divide and conquer, packed together. QPTR points to
+*         beginning of the submatrices.
+*
+*  QPTR   (input/output) INTEGER array, dimension (N+2)
+*         List of indices pointing to beginning of submatrices stored
+*         in QSTORE. The submatrices are numbered starting at the
+*         bottom left of the divide and conquer tree, from left to
+*         right and bottom to top.
+*
+*  PRMPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in PERM a
+*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
+*         indicates the size of the permutation and also the size of
+*         the full, non-deflated problem.
+*
+*  PERM   (input) INTEGER array, dimension (N lg N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in GIVCOL a
+*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
+*         indicates the number of Givens rotations.
+*
+*  GIVCOL (input) INTEGER array, dimension (2, N lg N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (input) REAL array, dimension (2, N lg N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  WORK   (workspace) REAL array, dimension (3*N+QSIZ*N)
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
+     $                   IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED7', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in SLAED8 and SLAED9.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         LDQ2 = QSIZ
+      ELSE
+         LDQ2 = N
+      END IF
+*
+      IZ = 1
+      IDLMDA = IZ + N
+      IW = IDLMDA + N
+      IQ2 = IW + N
+      IS = IQ2 + N*LDQ2
+*
+      INDX = 1
+      INDXC = INDX + N
+      COLTYP = INDXC + N
+      INDXP = COLTYP + N
+*
+*     Form the z-vector which consists of the last row of Q_1 and the
+*     first row of Q_2.
+*
+      PTR = 1 + 2**TLVLS
+      DO 10 I = 1, CURLVL - 1
+         PTR = PTR + 2**( TLVLS-I )
+   10 CONTINUE
+      CURR = PTR + CURPBM
+      CALL SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+     $             GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
+     $             WORK( IZ+N ), INFO )
+*
+*     When solving the final problem, we no longer need the stored data,
+*     so we will overwrite the data from this level onto the previously
+*     used storage space.
+*
+      IF( CURLVL.EQ.TLVLS ) THEN
+         QPTR( CURR ) = 1
+         PRMPTR( CURR ) = 1
+         GIVPTR( CURR ) = 1
+      END IF
+*
+*     Sort and Deflate eigenvalues.
+*
+      CALL SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
+     $             WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
+     $             WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
+     $             GIVCOL( 1, GIVPTR( CURR ) ),
+     $             GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
+     $             IWORK( INDX ), INFO )
+      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
+      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
+*
+*     Solve Secular Equation.
+*
+      IF( K.NE.0 ) THEN
+         CALL SLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
+     $                WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 30
+         IF( ICOMPQ.EQ.1 ) THEN
+            CALL SGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
+     $                  QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
+         END IF
+         QPTR( CURR+1 ) = QPTR( CURR ) + K**2
+*
+*     Prepare the INDXQ sorting permutation.
+*
+         N1 = K
+         N2 = N - K
+         CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
+      ELSE
+         QPTR( CURR+1 ) = QPTR( CURR )
+         DO 20 I = 1, N
+            INDXQ( I ) = I
+   20    CONTINUE
+      END IF
+*
+   30 CONTINUE
+      RETURN
+*
+*     End of SLAED7
+*
+      END
diff --git a/SRC/slaed8.f b/SRC/slaed8.f
new file mode 100644
index 00000000..4ee41f74
--- /dev/null
+++ b/SRC/slaed8.f
@@ -0,0 +1,399 @@
+      SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
+     $                   CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
+     $                   GIVCOL, GIVNUM, INDXP, INDX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
+     $                   QSIZ
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),
+     $                   INDXQ( * ), PERM( * )
+      REAL               D( * ), DLAMDA( * ), GIVNUM( 2, * ),
+     $                   Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED8 merges the two sets of eigenvalues together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  eigenvalues are close together or if there is a tiny element in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          = 0:  Compute eigenvalues only.
+*          = 1:  Compute eigenvectors of original dense symmetric matrix
+*                also.  On entry, Q contains the orthogonal matrix used
+*                to reduce the original matrix to tridiagonal form.
+*
+*  K      (output) INTEGER
+*         The number of non-deflated eigenvalues, and the order of the
+*         related secular equation.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the orthogonal matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry, the eigenvalues of the two submatrices to be
+*         combined.  On exit, the trailing (N-K) updated eigenvalues
+*         (those which were deflated) sorted into increasing order.
+*
+*  Q      (input/output) REAL array, dimension (LDQ,N)
+*         If ICOMPQ = 0, Q is not referenced.  Otherwise,
+*         on entry, Q contains the eigenvectors of the partially solved
+*         system which has been previously updated in matrix
+*         multiplies with other partially solved eigensystems.
+*         On exit, Q contains the trailing (N-K) updated eigenvectors
+*         (those which were deflated) in its last N-K columns.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  INDXQ  (input) INTEGER array, dimension (N)
+*         The permutation which separately sorts the two sub-problems
+*         in D into ascending order.  Note that elements in the second
+*         half of this permutation must first have CUTPNT added to
+*         their values in order to be accurate.
+*
+*  RHO    (input/output) REAL
+*         On entry, the off-diagonal element associated with the rank-1
+*         cut which originally split the two submatrices which are now
+*         being recombined.
+*         On exit, RHO has been modified to the value required by
+*         SLAED3.
+*
+*  CUTPNT (input) INTEGER
+*         The location of the last eigenvalue in the leading
+*         sub-matrix.  min(1,N) <= CUTPNT <= N.
+*
+*  Z      (input) REAL array, dimension (N)
+*         On entry, Z contains the updating vector (the last row of
+*         the first sub-eigenvector matrix and the first row of the
+*         second sub-eigenvector matrix).
+*         On exit, the contents of Z are destroyed by the updating
+*         process.
+*
+*  DLAMDA (output) REAL array, dimension (N)
+*         A copy of the first K eigenvalues which will be used by
+*         SLAED3 to form the secular equation.
+*
+*  Q2     (output) REAL array, dimension (LDQ2,N)
+*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
+*         a copy of the first K eigenvectors which will be used by
+*         SLAED7 in a matrix multiply (SGEMM) to update the new
+*         eigenvectors.
+*
+*  LDQ2   (input) INTEGER
+*         The leading dimension of the array Q2.  LDQ2 >= max(1,N).
+*
+*  W      (output) REAL array, dimension (N)
+*         The first k values of the final deflation-altered z-vector and
+*         will be passed to SLAED3.
+*
+*  PERM   (output) INTEGER array, dimension (N)
+*         The permutations (from deflation and sorting) to be applied
+*         to each eigenblock.
+*
+*  GIVPTR (output) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem.
+*
+*  GIVCOL (output) INTEGER array, dimension (2, N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (output) REAL array, dimension (2, N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  INDXP  (workspace) INTEGER array, dimension (N)
+*         The permutation used to place deflated values of D at the end
+*         of the array.  INDXP(1:K) points to the nondeflated D-values
+*         and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+*  INDX   (workspace) INTEGER array, dimension (N)
+*         The permutation used to sort the contents of D into ascending
+*         order.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               MONE, ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
+     $                   TWO = 2.0E0, EIGHT = 8.0E0 )
+*     ..
+*     .. Local Scalars ..
+*
+      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
+      REAL               C, EPS, S, T, TAU, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           ISAMAX, SLAMCH, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
+         INFO = -10
+      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED8', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      N1 = CUTPNT
+      N2 = N - N1
+      N1P1 = N1 + 1
+*
+      IF( RHO.LT.ZERO ) THEN
+         CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
+      END IF
+*
+*     Normalize z so that norm(z) = 1
+*
+      T = ONE / SQRT( TWO )
+      DO 10 J = 1, N
+         INDX( J ) = J
+   10 CONTINUE
+      CALL SSCAL( N, T, Z, 1 )
+      RHO = ABS( TWO*RHO )
+*
+*     Sort the eigenvalues into increasing order
+*
+      DO 20 I = CUTPNT + 1, N
+         INDXQ( I ) = INDXQ( I ) + CUTPNT
+   20 CONTINUE
+      DO 30 I = 1, N
+         DLAMDA( I ) = D( INDXQ( I ) )
+         W( I ) = Z( INDXQ( I ) )
+   30 CONTINUE
+      I = 1
+      J = CUTPNT + 1
+      CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
+      DO 40 I = 1, N
+         D( I ) = DLAMDA( INDX( I ) )
+         Z( I ) = W( INDX( I ) )
+   40 CONTINUE
+*
+*     Calculate the allowable deflation tolerence
+*
+      IMAX = ISAMAX( N, Z, 1 )
+      JMAX = ISAMAX( N, D, 1 )
+      EPS = SLAMCH( 'Epsilon' )
+      TOL = EIGHT*EPS*ABS( D( JMAX ) )
+*
+*     If the rank-1 modifier is small enough, no more needs to be done
+*     except to reorganize Q so that its columns correspond with the
+*     elements in D.
+*
+      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+         K = 0
+         IF( ICOMPQ.EQ.0 ) THEN
+            DO 50 J = 1, N
+               PERM( J ) = INDXQ( INDX( J ) )
+   50       CONTINUE
+         ELSE
+            DO 60 J = 1, N
+               PERM( J ) = INDXQ( INDX( J ) )
+               CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+   60       CONTINUE
+            CALL SLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
+     $                   LDQ )
+         END IF
+         RETURN
+      END IF
+*
+*     If there are multiple eigenvalues then the problem deflates.  Here
+*     the number of equal eigenvalues are found.  As each equal
+*     eigenvalue is found, an elementary reflector is computed to rotate
+*     the corresponding eigensubspace so that the corresponding
+*     components of Z are zero in this new basis.
+*
+      K = 0
+      GIVPTR = 0
+      K2 = N + 1
+      DO 70 J = 1, N
+         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            INDXP( K2 ) = J
+            IF( J.EQ.N )
+     $         GO TO 110
+         ELSE
+            JLAM = J
+            GO TO 80
+         END IF
+   70 CONTINUE
+   80 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 100
+      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         INDXP( K2 ) = J
+      ELSE
+*
+*        Check if eigenvalues are close enough to allow deflation.
+*
+         S = Z( JLAM )
+         C = Z( J )
+*
+*        Find sqrt(a**2+b**2) without overflow or
+*        destructive underflow.
+*
+         TAU = SLAPY2( C, S )
+         T = D( J ) - D( JLAM )
+         C = C / TAU
+         S = -S / TAU
+         IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            Z( J ) = TAU
+            Z( JLAM ) = ZERO
+*
+*           Record the appropriate Givens rotation
+*
+            GIVPTR = GIVPTR + 1
+            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
+            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
+            GIVNUM( 1, GIVPTR ) = C
+            GIVNUM( 2, GIVPTR ) = S
+            IF( ICOMPQ.EQ.1 ) THEN
+               CALL SROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
+     $                    Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
+            END IF
+            T = D( JLAM )*C*C + D( J )*S*S
+            D( J ) = D( JLAM )*S*S + D( J )*C*C
+            D( JLAM ) = T
+            K2 = K2 - 1
+            I = 1
+   90       CONTINUE
+            IF( K2+I.LE.N ) THEN
+               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
+                  INDXP( K2+I-1 ) = INDXP( K2+I )
+                  INDXP( K2+I ) = JLAM
+                  I = I + 1
+                  GO TO 90
+               ELSE
+                  INDXP( K2+I-1 ) = JLAM
+               END IF
+            ELSE
+               INDXP( K2+I-1 ) = JLAM
+            END IF
+            JLAM = J
+         ELSE
+            K = K + 1
+            W( K ) = Z( JLAM )
+            DLAMDA( K ) = D( JLAM )
+            INDXP( K ) = JLAM
+            JLAM = J
+         END IF
+      END IF
+      GO TO 80
+  100 CONTINUE
+*
+*     Record the last eigenvalue.
+*
+      K = K + 1
+      W( K ) = Z( JLAM )
+      DLAMDA( K ) = D( JLAM )
+      INDXP( K ) = JLAM
+*
+  110 CONTINUE
+*
+*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+*     and Q2 respectively.  The eigenvalues/vectors which were not
+*     deflated go into the first K slots of DLAMDA and Q2 respectively,
+*     while those which were deflated go into the last N - K slots.
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+         DO 120 J = 1, N
+            JP = INDXP( J )
+            DLAMDA( J ) = D( JP )
+            PERM( J ) = INDXQ( INDX( JP ) )
+  120    CONTINUE
+      ELSE
+         DO 130 J = 1, N
+            JP = INDXP( J )
+            DLAMDA( J ) = D( JP )
+            PERM( J ) = INDXQ( INDX( JP ) )
+            CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+  130    CONTINUE
+      END IF
+*
+*     The deflated eigenvalues and their corresponding vectors go back
+*     into the last N - K slots of D and Q respectively.
+*
+      IF( K.LT.N ) THEN
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+         ELSE
+            CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+            CALL SLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
+     $                   Q( 1, K+1 ), LDQ )
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of SLAED8
+*
+      END
diff --git a/SRC/slaed9.f b/SRC/slaed9.f
new file mode 100644
index 00000000..86cfb6fb
--- /dev/null
+++ b/SRC/slaed9.f
@@ -0,0 +1,205 @@
+      SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
+     $                   S, LDS, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, KSTART, KSTOP, LDQ, LDS, N
+      REAL               RHO
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
+     $                   W( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAED9 finds the roots of the secular equation, as defined by the
+*  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the
+*  appropriate calls to SLAED4 and then stores the new matrix of
+*  eigenvectors for use in calculating the next level of Z vectors.
+*
+*  Arguments
+*  =========
+*
+*  K       (input) INTEGER
+*          The number of terms in the rational function to be solved by
+*          SLAED4.  K >= 0.
+*
+*  KSTART  (input) INTEGER
+*  KSTOP   (input) INTEGER
+*          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
+*          are to be computed.  1 <= KSTART <= KSTOP <= K.
+*
+*  N       (input) INTEGER
+*          The number of rows and columns in the Q matrix.
+*          N >= K (delation may result in N > K).
+*
+*  D       (output) REAL array, dimension (N)
+*          D(I) contains the updated eigenvalues
+*          for KSTART <= I <= KSTOP.
+*
+*  Q       (workspace) REAL array, dimension (LDQ,N)
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= max( 1, N ).
+*
+*  RHO     (input) REAL
+*          The value of the parameter in the rank one update equation.
+*          RHO >= 0 required.
+*
+*  DLAMDA  (input) REAL array, dimension (K)
+*          The first K elements of this array contain the old roots
+*          of the deflated updating problem.  These are the poles
+*          of the secular equation.
+*
+*  W       (input) REAL array, dimension (K)
+*          The first K elements of this array contain the components
+*          of the deflation-adjusted updating vector.
+*
+*  S       (output) REAL array, dimension (LDS, K)
+*          Will contain the eigenvectors of the repaired matrix which
+*          will be stored for subsequent Z vector calculation and
+*          multiplied by the previously accumulated eigenvectors
+*          to update the system.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of S.  LDS >= max( 1, K ).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               TEMP
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3, SNRM2
+      EXTERNAL           SLAMC3, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAED4, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( K.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
+         INFO = -2
+      ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( N.LT.K ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAED9', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 )
+     $   RETURN
+*
+*     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DLAMDA(I) if it is 1; this makes the subsequent
+*     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DLAMDA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DLAMDA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 10 I = 1, N
+         DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+   10 CONTINUE
+*
+      DO 20 J = KSTART, KSTOP
+         CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+*        If the zero finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 )
+     $      GO TO 120
+   20 CONTINUE
+*
+      IF( K.EQ.1 .OR. K.EQ.2 ) THEN
+         DO 40 I = 1, K
+            DO 30 J = 1, K
+               S( J, I ) = Q( J, I )
+   30       CONTINUE
+   40    CONTINUE
+         GO TO 120
+      END IF
+*
+*     Compute updated W.
+*
+      CALL SCOPY( K, W, 1, S, 1 )
+*
+*     Initialize W(I) = Q(I,I)
+*
+      CALL SCOPY( K, Q, LDQ+1, W, 1 )
+      DO 70 J = 1, K
+         DO 50 I = 1, J - 1
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   50    CONTINUE
+         DO 60 I = J + 1, K
+            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+   60    CONTINUE
+   70 CONTINUE
+      DO 80 I = 1, K
+         W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
+   80 CONTINUE
+*
+*     Compute eigenvectors of the modified rank-1 modification.
+*
+      DO 110 J = 1, K
+         DO 90 I = 1, K
+            Q( I, J ) = W( I ) / Q( I, J )
+   90    CONTINUE
+         TEMP = SNRM2( K, Q( 1, J ), 1 )
+         DO 100 I = 1, K
+            S( I, J ) = Q( I, J ) / TEMP
+  100    CONTINUE
+  110 CONTINUE
+*
+  120 CONTINUE
+      RETURN
+*
+*     End of SLAED9
+*
+      END
diff --git a/SRC/slaeda.f b/SRC/slaeda.f
new file mode 100644
index 00000000..7039ff52
--- /dev/null
+++ b/SRC/slaeda.f
@@ -0,0 +1,217 @@
+      SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+     $                   GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CURLVL, CURPBM, INFO, N, TLVLS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
+     $                   PRMPTR( * ), QPTR( * )
+      REAL               GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAEDA computes the Z vector corresponding to the merge step in the
+*  CURLVLth step of the merge process with TLVLS steps for the CURPBMth
+*  problem.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  TLVLS  (input) INTEGER
+*         The total number of merging levels in the overall divide and
+*         conquer tree.
+*
+*  CURLVL (input) INTEGER
+*         The current level in the overall merge routine,
+*         0 <= curlvl <= tlvls.
+*
+*  CURPBM (input) INTEGER
+*         The current problem in the current level in the overall
+*         merge routine (counting from upper left to lower right).
+*
+*  PRMPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in PERM a
+*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
+*         indicates the size of the permutation and incidentally the
+*         size of the full, non-deflated problem.
+*
+*  PERM   (input) INTEGER array, dimension (N lg N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in GIVCOL a
+*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
+*         indicates the number of Givens rotations.
+*
+*  GIVCOL (input) INTEGER array, dimension (2, N lg N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (input) REAL array, dimension (2, N lg N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  Q      (input) REAL array, dimension (N**2)
+*         Contains the square eigenblocks from previous levels, the
+*         starting positions for blocks are given by QPTR.
+*
+*  QPTR   (input) INTEGER array, dimension (N+2)
+*         Contains a list of pointers which indicate where in Q an
+*         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates
+*         the size of the block.
+*
+*  Z      (output) REAL array, dimension (N)
+*         On output this vector contains the updating vector (the last
+*         row of the first sub-eigenvector matrix and the first row of
+*         the second sub-eigenvector matrix).
+*
+*  ZTEMP  (workspace) REAL array, dimension (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
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
+     $                   PTR, ZPTR1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMV, SROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAEDA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine location of first number in second half.
+*
+      MID = N / 2 + 1
+*
+*     Gather last/first rows of appropriate eigenblocks into center of Z
+*
+      PTR = 1
+*
+*     Determine location of lowest level subproblem in the full storage
+*     scheme
+*
+      CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
+*
+*     Determine size of these matrices.  We add HALF to the value of
+*     the SQRT in case the machine underestimates one of these square
+*     roots.
+*
+      BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+      BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
+      DO 10 K = 1, MID - BSIZ1 - 1
+         Z( K ) = ZERO
+   10 CONTINUE
+      CALL SCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
+     $            Z( MID-BSIZ1 ), 1 )
+      CALL SCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
+      DO 20 K = MID + BSIZ2, N
+         Z( K ) = ZERO
+   20 CONTINUE
+*
+*     Loop thru remaining levels 1 -> CURLVL applying the Givens
+*     rotations and permutation and then multiplying the center matrices
+*     against the current Z.
+*
+      PTR = 2**TLVLS + 1
+      DO 70 K = 1, CURLVL - 1
+         CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
+         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+         ZPTR1 = MID - PSIZ1
+*
+*       Apply Givens at CURR and CURR+1
+*
+         DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
+            CALL SROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
+     $                 Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
+     $                 GIVNUM( 2, I ) )
+   30    CONTINUE
+         DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
+            CALL SROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
+     $                 Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
+     $                 GIVNUM( 2, I ) )
+   40    CONTINUE
+         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+         DO 50 I = 0, PSIZ1 - 1
+            ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
+   50    CONTINUE
+         DO 60 I = 0, PSIZ2 - 1
+            ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
+   60    CONTINUE
+*
+*        Multiply Blocks at CURR and CURR+1
+*
+*        Determine size of these matrices.  We add HALF to the value of
+*        the SQRT in case the machine underestimates one of these
+*        square roots.
+*
+         BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+         BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+
+     $           1 ) ) ) )
+         IF( BSIZ1.GT.0 ) THEN
+            CALL SGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
+     $                  BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
+         END IF
+         CALL SCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
+     $               1 )
+         IF( BSIZ2.GT.0 ) THEN
+            CALL SGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
+     $                  BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
+         END IF
+         CALL SCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
+     $               Z( MID+BSIZ2 ), 1 )
+*
+         PTR = PTR + 2**( TLVLS-K )
+   70 CONTINUE
+*
+      RETURN
+*
+*     End of SLAEDA
+*
+      END
diff --git a/SRC/slaein.f b/SRC/slaein.f
new file mode 100644
index 00000000..d7d634d4
--- /dev/null
+++ b/SRC/slaein.f
@@ -0,0 +1,531 @@
+      SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
+     $                   LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            NOINIT, RIGHTV
+      INTEGER            INFO, LDB, LDH, N
+      REAL               BIGNUM, EPS3, SMLNUM, WI, WR
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAEIN uses inverse iteration to find a right or left eigenvector
+*  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
+*  matrix H.
+*
+*  Arguments
+*  =========
+*
+*  RIGHTV   (input) LOGICAL
+*          = .TRUE. : compute right eigenvector;
+*          = .FALSE.: compute left eigenvector.
+*
+*  NOINIT   (input) LOGICAL
+*          = .TRUE. : no initial vector supplied in (VR,VI).
+*          = .FALSE.: initial vector supplied in (VR,VI).
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) REAL array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  WR      (input) REAL
+*  WI      (input) REAL
+*          The real and imaginary parts of the eigenvalue of H whose
+*          corresponding right or left eigenvector is to be computed.
+*
+*  VR      (input/output) REAL array, dimension (N)
+*  VI      (input/output) REAL array, dimension (N)
+*          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
+*          a real starting vector for inverse iteration using the real
+*          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
+*          must contain the real and imaginary parts of a complex
+*          starting vector for inverse iteration using the complex
+*          eigenvalue (WR,WI); otherwise VR and VI need not be set.
+*          On exit, if WI = 0.0 (real eigenvalue), VR contains the
+*          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
+*          VR and VI contain the real and imaginary parts of the
+*          computed complex eigenvector. The eigenvector is normalized
+*          so that the component of largest magnitude has magnitude 1;
+*          here the magnitude of a complex number (x,y) is taken to be
+*          |x| + |y|.
+*          VI is not referenced if WI = 0.0.
+*
+*  B       (workspace) REAL array, dimension (LDB,N)
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= N+1.
+*
+*  WORK   (workspace) REAL array, dimension (N)
+*
+*  EPS3    (input) REAL
+*          A small machine-dependent value which is used to perturb
+*          close eigenvalues, and to replace zero pivots.
+*
+*  SMLNUM  (input) REAL
+*          A machine-dependent value close to the underflow threshold.
+*
+*  BIGNUM  (input) REAL
+*          A machine-dependent value close to the overflow threshold.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          = 1:  inverse iteration did not converge; VR is set to the
+*                last iterate, and so is VI if WI.ne.0.0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TENTH
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TENTH = 1.0E-1 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          NORMIN, TRANS
+      INTEGER            I, I1, I2, I3, IERR, ITS, J
+      REAL               ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
+     $                   REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
+     $                   W1, X, XI, XR, Y
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SASUM, SLAPY2, SNRM2
+      EXTERNAL           ISAMAX, SASUM, SLAPY2, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLADIV, SLATRS, SSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     GROWTO is the threshold used in the acceptance test for an
+*     eigenvector.
+*
+      ROOTN = SQRT( REAL( N ) )
+      GROWTO = TENTH / ROOTN
+      NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
+*
+*     Form B = H - (WR,WI)*I (except that the subdiagonal elements and
+*     the imaginary parts of the diagonal elements are not stored).
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, J - 1
+            B( I, J ) = H( I, J )
+   10    CONTINUE
+         B( J, J ) = H( J, J ) - WR
+   20 CONTINUE
+*
+      IF( WI.EQ.ZERO ) THEN
+*
+*        Real eigenvalue.
+*
+         IF( NOINIT ) THEN
+*
+*           Set initial vector.
+*
+            DO 30 I = 1, N
+               VR( I ) = EPS3
+   30       CONTINUE
+         ELSE
+*
+*           Scale supplied initial vector.
+*
+            VNORM = SNRM2( N, VR, 1 )
+            CALL SSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
+     $                  1 )
+         END IF
+*
+         IF( RIGHTV ) THEN
+*
+*           LU decomposition with partial pivoting of B, replacing zero
+*           pivots by EPS3.
+*
+            DO 60 I = 1, N - 1
+               EI = H( I+1, I )
+               IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
+*
+*                 Interchange rows and eliminate.
+*
+                  X = B( I, I ) / EI
+                  B( I, I ) = EI
+                  DO 40 J = I + 1, N
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - X*TEMP
+                     B( I, J ) = TEMP
+   40             CONTINUE
+               ELSE
+*
+*                 Eliminate without interchange.
+*
+                  IF( B( I, I ).EQ.ZERO )
+     $               B( I, I ) = EPS3
+                  X = EI / B( I, I )
+                  IF( X.NE.ZERO ) THEN
+                     DO 50 J = I + 1, N
+                        B( I+1, J ) = B( I+1, J ) - X*B( I, J )
+   50                CONTINUE
+                  END IF
+               END IF
+   60       CONTINUE
+            IF( B( N, N ).EQ.ZERO )
+     $         B( N, N ) = EPS3
+*
+            TRANS = 'N'
+*
+         ELSE
+*
+*           UL decomposition with partial pivoting of B, replacing zero
+*           pivots by EPS3.
+*
+            DO 90 J = N, 2, -1
+               EJ = H( J, J-1 )
+               IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
+*
+*                 Interchange columns and eliminate.
+*
+                  X = B( J, J ) / EJ
+                  B( J, J ) = EJ
+                  DO 70 I = 1, J - 1
+                     TEMP = B( I, J-1 )
+                     B( I, J-1 ) = B( I, J ) - X*TEMP
+                     B( I, J ) = TEMP
+   70             CONTINUE
+               ELSE
+*
+*                 Eliminate without interchange.
+*
+                  IF( B( J, J ).EQ.ZERO )
+     $               B( J, J ) = EPS3
+                  X = EJ / B( J, J )
+                  IF( X.NE.ZERO ) THEN
+                     DO 80 I = 1, J - 1
+                        B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
+   80                CONTINUE
+                  END IF
+               END IF
+   90       CONTINUE
+            IF( B( 1, 1 ).EQ.ZERO )
+     $         B( 1, 1 ) = EPS3
+*
+            TRANS = 'T'
+*
+         END IF
+*
+         NORMIN = 'N'
+         DO 110 ITS = 1, N
+*
+*           Solve U*x = scale*v for a right eigenvector
+*             or U'*x = scale*v for a left eigenvector,
+*           overwriting x on v.
+*
+            CALL SLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
+     $                   VR, SCALE, WORK, IERR )
+            NORMIN = 'Y'
+*
+*           Test for sufficient growth in the norm of v.
+*
+            VNORM = SASUM( N, VR, 1 )
+            IF( VNORM.GE.GROWTO*SCALE )
+     $         GO TO 120
+*
+*           Choose new orthogonal starting vector and try again.
+*
+            TEMP = EPS3 / ( ROOTN+ONE )
+            VR( 1 ) = EPS3
+            DO 100 I = 2, N
+               VR( I ) = TEMP
+  100       CONTINUE
+            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+  110    CONTINUE
+*
+*        Failure to find eigenvector in N iterations.
+*
+         INFO = 1
+*
+  120    CONTINUE
+*
+*        Normalize eigenvector.
+*
+         I = ISAMAX( N, VR, 1 )
+         CALL SSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
+      ELSE
+*
+*        Complex eigenvalue.
+*
+         IF( NOINIT ) THEN
+*
+*           Set initial vector.
+*
+            DO 130 I = 1, N
+               VR( I ) = EPS3
+               VI( I ) = ZERO
+  130       CONTINUE
+         ELSE
+*
+*           Scale supplied initial vector.
+*
+            NORM = SLAPY2( SNRM2( N, VR, 1 ), SNRM2( N, VI, 1 ) )
+            REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
+            CALL SSCAL( N, REC, VR, 1 )
+            CALL SSCAL( N, REC, VI, 1 )
+         END IF
+*
+         IF( RIGHTV ) THEN
+*
+*           LU decomposition with partial pivoting of B, replacing zero
+*           pivots by EPS3.
+*
+*           The imaginary part of the (i,j)-th element of U is stored in
+*           B(j+1,i).
+*
+            B( 2, 1 ) = -WI
+            DO 140 I = 2, N
+               B( I+1, 1 ) = ZERO
+  140       CONTINUE
+*
+            DO 170 I = 1, N - 1
+               ABSBII = SLAPY2( B( I, I ), B( I+1, I ) )
+               EI = H( I+1, I )
+               IF( ABSBII.LT.ABS( EI ) ) THEN
+*
+*                 Interchange rows and eliminate.
+*
+                  XR = B( I, I ) / EI
+                  XI = B( I+1, I ) / EI
+                  B( I, I ) = EI
+                  B( I+1, I ) = ZERO
+                  DO 150 J = I + 1, N
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - XR*TEMP
+                     B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
+                     B( I, J ) = TEMP
+                     B( J+1, I ) = ZERO
+  150             CONTINUE
+                  B( I+2, I ) = -WI
+                  B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
+                  B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
+               ELSE
+*
+*                 Eliminate without interchanging rows.
+*
+                  IF( ABSBII.EQ.ZERO ) THEN
+                     B( I, I ) = EPS3
+                     B( I+1, I ) = ZERO
+                     ABSBII = EPS3
+                  END IF
+                  EI = ( EI / ABSBII ) / ABSBII
+                  XR = B( I, I )*EI
+                  XI = -B( I+1, I )*EI
+                  DO 160 J = I + 1, N
+                     B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
+     $                             XI*B( J+1, I )
+                     B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
+  160             CONTINUE
+                  B( I+2, I+1 ) = B( I+2, I+1 ) - WI
+               END IF
+*
+*              Compute 1-norm of offdiagonal elements of i-th row.
+*
+               WORK( I ) = SASUM( N-I, B( I, I+1 ), LDB ) +
+     $                     SASUM( N-I, B( I+2, I ), 1 )
+  170       CONTINUE
+            IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
+     $         B( N, N ) = EPS3
+            WORK( N ) = ZERO
+*
+            I1 = N
+            I2 = 1
+            I3 = -1
+         ELSE
+*
+*           UL decomposition with partial pivoting of conjg(B),
+*           replacing zero pivots by EPS3.
+*
+*           The imaginary part of the (i,j)-th element of U is stored in
+*           B(j+1,i).
+*
+            B( N+1, N ) = WI
+            DO 180 J = 1, N - 1
+               B( N+1, J ) = ZERO
+  180       CONTINUE
+*
+            DO 210 J = N, 2, -1
+               EJ = H( J, J-1 )
+               ABSBJJ = SLAPY2( B( J, J ), B( J+1, J ) )
+               IF( ABSBJJ.LT.ABS( EJ ) ) THEN
+*
+*                 Interchange columns and eliminate
+*
+                  XR = B( J, J ) / EJ
+                  XI = B( J+1, J ) / EJ
+                  B( J, J ) = EJ
+                  B( J+1, J ) = ZERO
+                  DO 190 I = 1, J - 1
+                     TEMP = B( I, J-1 )
+                     B( I, J-1 ) = B( I, J ) - XR*TEMP
+                     B( J, I ) = B( J+1, I ) - XI*TEMP
+                     B( I, J ) = TEMP
+                     B( J+1, I ) = ZERO
+  190             CONTINUE
+                  B( J+1, J-1 ) = WI
+                  B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
+                  B( J, J-1 ) = B( J, J-1 ) - XR*WI
+               ELSE
+*
+*                 Eliminate without interchange.
+*
+                  IF( ABSBJJ.EQ.ZERO ) THEN
+                     B( J, J ) = EPS3
+                     B( J+1, J ) = ZERO
+                     ABSBJJ = EPS3
+                  END IF
+                  EJ = ( EJ / ABSBJJ ) / ABSBJJ
+                  XR = B( J, J )*EJ
+                  XI = -B( J+1, J )*EJ
+                  DO 200 I = 1, J - 1
+                     B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
+     $                             XI*B( J+1, I )
+                     B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
+  200             CONTINUE
+                  B( J, J-1 ) = B( J, J-1 ) + WI
+               END IF
+*
+*              Compute 1-norm of offdiagonal elements of j-th column.
+*
+               WORK( J ) = SASUM( J-1, B( 1, J ), 1 ) +
+     $                     SASUM( J-1, B( J+1, 1 ), LDB )
+  210       CONTINUE
+            IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
+     $         B( 1, 1 ) = EPS3
+            WORK( 1 ) = ZERO
+*
+            I1 = 1
+            I2 = N
+            I3 = 1
+         END IF
+*
+         DO 270 ITS = 1, N
+            SCALE = ONE
+            VMAX = ONE
+            VCRIT = BIGNUM
+*
+*           Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
+*             or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
+*           overwriting (xr,xi) on (vr,vi).
+*
+            DO 250 I = I1, I2, I3
+*
+               IF( WORK( I ).GT.VCRIT ) THEN
+                  REC = ONE / VMAX
+                  CALL SSCAL( N, REC, VR, 1 )
+                  CALL SSCAL( N, REC, VI, 1 )
+                  SCALE = SCALE*REC
+                  VMAX = ONE
+                  VCRIT = BIGNUM
+               END IF
+*
+               XR = VR( I )
+               XI = VI( I )
+               IF( RIGHTV ) THEN
+                  DO 220 J = I + 1, N
+                     XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
+                     XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
+  220             CONTINUE
+               ELSE
+                  DO 230 J = 1, I - 1
+                     XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
+                     XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
+  230             CONTINUE
+               END IF
+*
+               W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
+               IF( W.GT.SMLNUM ) THEN
+                  IF( W.LT.ONE ) THEN
+                     W1 = ABS( XR ) + ABS( XI )
+                     IF( W1.GT.W*BIGNUM ) THEN
+                        REC = ONE / W1
+                        CALL SSCAL( N, REC, VR, 1 )
+                        CALL SSCAL( N, REC, VI, 1 )
+                        XR = VR( I )
+                        XI = VI( I )
+                        SCALE = SCALE*REC
+                        VMAX = VMAX*REC
+                     END IF
+                  END IF
+*
+*                 Divide by diagonal element of B.
+*
+                  CALL SLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
+     $                         VI( I ) )
+                  VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
+                  VCRIT = BIGNUM / VMAX
+               ELSE
+                  DO 240 J = 1, N
+                     VR( J ) = ZERO
+                     VI( J ) = ZERO
+  240             CONTINUE
+                  VR( I ) = ONE
+                  VI( I ) = ONE
+                  SCALE = ZERO
+                  VMAX = ONE
+                  VCRIT = BIGNUM
+               END IF
+  250       CONTINUE
+*
+*           Test for sufficient growth in the norm of (VR,VI).
+*
+            VNORM = SASUM( N, VR, 1 ) + SASUM( N, VI, 1 )
+            IF( VNORM.GE.GROWTO*SCALE )
+     $         GO TO 280
+*
+*           Choose a new orthogonal starting vector and try again.
+*
+            Y = EPS3 / ( ROOTN+ONE )
+            VR( 1 ) = EPS3
+            VI( 1 ) = ZERO
+*
+            DO 260 I = 2, N
+               VR( I ) = Y
+               VI( I ) = ZERO
+  260       CONTINUE
+            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+  270    CONTINUE
+*
+*        Failure to find eigenvector in N iterations
+*
+         INFO = 1
+*
+  280    CONTINUE
+*
+*        Normalize eigenvector.
+*
+         VNORM = ZERO
+         DO 290 I = 1, N
+            VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
+  290    CONTINUE
+         CALL SSCAL( N, ONE / VNORM, VR, 1 )
+         CALL SSCAL( N, ONE / VNORM, VI, 1 )
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLAEIN
+*
+      END
diff --git a/SRC/slaev2.f b/SRC/slaev2.f
new file mode 100644
index 00000000..965cf601
--- /dev/null
+++ b/SRC/slaev2.f
@@ -0,0 +1,169 @@
+      SUBROUTINE SLAEV2( 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 ..
+      REAL               A, B, C, CS1, RT1, RT2, SN1
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAEV2 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) REAL
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  B       (input) REAL
+*          The (1,2) element and the conjugate of the (2,1) element of
+*          the 2-by-2 matrix.
+*
+*  C       (input) REAL
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  RT1     (output) REAL
+*          The eigenvalue of larger absolute value.
+*
+*  RT2     (output) REAL
+*          The eigenvalue of smaller absolute value.
+*
+*  CS1     (output) REAL
+*  SN1     (output) REAL
+*          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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E0 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               HALF
+      PARAMETER          ( HALF = 0.5E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            SGN1, SGN2
+      REAL               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 SLAEV2
+*
+      END
diff --git a/SRC/slaexc.f b/SRC/slaexc.f
new file mode 100644
index 00000000..bbc16798
--- /dev/null
+++ b/SRC/slaexc.f
@@ -0,0 +1,353 @@
+      SUBROUTINE SLAEXC( 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 ..
+      REAL               Q( LDQ, * ), T( LDT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAEXC 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) REAL array, dimension (LDT,N)
+*          On entry, the upper quasi-triangular matrix T, in Schur
+*          canonical form.
+*          On exit, the updated matrix T, again in Schur canonical form.
+*
+*  LDT     (input)  INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) REAL 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) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          = 1: the transformed matrix T would be too far from Schur
+*               form; the blocks are not swapped and T and Q are
+*               unchanged.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               TEN
+      PARAMETER          ( TEN = 1.0E+1 )
+      INTEGER            LDD, LDX
+      PARAMETER          ( LDD = 4, LDX = 2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IERR, J2, J3, J4, K, ND
+      REAL               CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
+     $                   T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
+     $                   WR1, WR2, XNORM
+*     ..
+*     .. Local Arrays ..
+      REAL               D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
+     $                   X( LDX, 2 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLANGE
+      EXTERNAL           SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACPY, SLANV2, SLARFG, SLARFX, SLARTG, SLASY2,
+     $                   SROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
+     $   RETURN
+      IF( J1+N1.GT.N )
+     $   RETURN
+*
+      J2 = J1 + 1
+      J3 = J1 + 2
+      J4 = J1 + 3
+*
+      IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
+*
+*        Swap two 1-by-1 blocks.
+*
+         T11 = T( J1, J1 )
+         T22 = T( J2, J2 )
+*
+*        Determine the transformation to perform the interchange.
+*
+         CALL SLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
+*
+*        Apply transformation to the matrix T.
+*
+         IF( J3.LE.N )
+     $      CALL SROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
+     $                 SN )
+         CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+*
+         T( J1, J1 ) = T22
+         T( J2, J2 ) = T11
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL SROT( 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 SLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
+         DNORM = SLANGE( 'Max', ND, ND, D, LDD, WORK )
+*
+*        Compute machine-dependent threshold for test for accepting
+*        swap.
+*
+         EPS = SLAMCH( 'P' )
+         SMLNUM = SLAMCH( 'S' ) / EPS
+         THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+*        Solve T11*X - X*T22 = scale*T12 for X.
+*
+         CALL SLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
+     $                D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X,
+     $                LDX, XNORM, IERR )
+*
+*        Swap the adjacent diagonal blocks.
+*
+         K = N1 + N1 + N2 - 3
+         GO TO ( 10, 20, 30 )K
+*
+   10    CONTINUE
+*
+*        N1 = 1, N2 = 2: generate elementary reflector H so that:
+*
+*        ( scale, X11, X12 ) H = ( 0, 0, * )
+*
+         U( 1 ) = SCALE
+         U( 2 ) = X( 1, 1 )
+         U( 3 ) = X( 1, 2 )
+         CALL SLARFG( 3, U( 3 ), U, 1, TAU )
+         U( 3 ) = ONE
+         T11 = T( J1, J1 )
+*
+*        Perform swap provisionally on diagonal block in D.
+*
+         CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+         CALL SLARFX( '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 SLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
+         CALL SLARFX( '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 SLARFX( '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 SLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
+         U( 1 ) = ONE
+         T33 = T( J3, J3 )
+*
+*        Perform swap provisionally on diagonal block in D.
+*
+         CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+         CALL SLARFX( '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 SLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+         CALL SLARFX( '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 SLARFX( '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 SLARFG( 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 SLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
+         U2( 1 ) = ONE
+*
+*        Perform swap provisionally on diagonal block in D.
+*
+         CALL SLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
+         CALL SLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
+         CALL SLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
+         CALL SLARFX( '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 SLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
+         CALL SLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
+         CALL SLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
+         CALL SLARFX( '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 SLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
+            CALL SLARFX( '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 SLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
+     $                   T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
+            CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
+     $                 CS, SN )
+            CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+            IF( WANTQ )
+     $         CALL SROT( 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 SLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
+     $                   T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
+            IF( J3+2.LE.N )
+     $         CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
+     $                    LDT, CS, SN )
+            CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
+            IF( WANTQ )
+     $         CALL SROT( 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 INFO = 1
+      RETURN
+*
+*     End of SLAEXC
+*
+      END
diff --git a/SRC/slag2.f b/SRC/slag2.f
new file mode 100644
index 00000000..94f6fd60
--- /dev/null
+++ b/SRC/slag2.f
@@ -0,0 +1,300 @@
+      SUBROUTINE SLAG2( 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
+      REAL               SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAG2 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) REAL 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) REAL 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) REAL
+*          The smallest positive number s.t. 1/SAFMIN does not
+*          overflow.  (This should always be SLAMCH('S') -- it is an
+*          argument in order to avoid having to call SLAMCH frequently.)
+*
+*  SCALE1  (output) REAL
+*          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) REAL
+*          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) REAL
+*          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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+      REAL               HALF
+      PARAMETER          ( HALF = ONE / TWO )
+      REAL               FUZZY1
+      PARAMETER          ( FUZZY1 = ONE+1.0E-5 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 SLAG2
+*
+      RETURN
+      END
diff --git a/SRC/slag2d.f b/SRC/slag2d.f
new file mode 100644
index 00000000..d8081651
--- /dev/null
+++ b/SRC/slag2d.f
@@ -0,0 +1,73 @@
+      SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO)
+*
+*  -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     ..
+*     .. WARNING: PROTOTYPE ..
+*     This is an LAPACK PROTOTYPE routine which means that the
+*     interface of this routine is likely to be changed in the future
+*     based on community feedback.
+*
+*     .. Scalar Arguments ..
+      INTEGER INFO,LDA,LDSA,M,N
+*     ..
+*     .. Array Arguments ..
+      REAL SA(LDSA,*)
+      DOUBLE PRECISION A(LDA,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE
+*  PRECISION matrix, A.
+*
+*  Note that while it is possible to overflow while converting 
+*  from double to single, it is not possible to overflow when
+*  converting from single to double. 
+*
+*  This is a helper routine so there is no argument checking.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of lines of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  SA      (output) REAL array, dimension (LDSA,N)
+*          On exit, the M-by-N coefficient matrix SA.
+*
+*  LDSA    (input) INTEGER
+*          The leading dimension of the array SA.  LDSA >= max(1,M).
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N coefficient matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*  =========
+*
+*     .. Local Scalars ..
+      INTEGER I,J
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      DO 20 J = 1,N
+          DO 30 I = 1,M
+              A(I,J) = SA(I,J)
+   30     CONTINUE
+   20 CONTINUE
+      RETURN
+*
+*     End of SLAG2D
+*
+      END
diff --git a/SRC/slags2.f b/SRC/slags2.f
new file mode 100644
index 00000000..8c224864
--- /dev/null
+++ b/SRC/slags2.f
@@ -0,0 +1,269 @@
+      SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
+     $                   SNV, CSQ, SNQ )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            UPPER
+      REAL               A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
+     $                   SNU, SNV
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
+*  that if ( UPPER ) then
+*
+*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
+*                        ( 0  A3 )     ( x  x  )
+*  and
+*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
+*                        ( 0  B3 )     ( x  x  )
+*
+*  or if ( .NOT.UPPER ) then
+*
+*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
+*                        ( A2 A3 )     ( 0  x  )
+*  and
+*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
+*                        ( B2 B3 )     ( 0  x  )
+*
+*  The rows of the transformed A and B are parallel, where
+*
+*    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
+*        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
+*
+*  Z' denotes the transpose of Z.
+*
+*
+*  Arguments
+*  =========
+*
+*  UPPER   (input) LOGICAL
+*          = .TRUE.: the input matrices A and B are upper triangular.
+*          = .FALSE.: the input matrices A and B are lower triangular.
+*
+*  A1      (input) REAL
+*  A2      (input) REAL
+*  A3      (input) REAL
+*          On entry, A1, A2 and A3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix A.
+*
+*  B1      (input) REAL
+*  B2      (input) REAL
+*  B3      (input) REAL
+*          On entry, B1, B2 and B3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix B.
+*
+*  CSU     (output) REAL
+*  SNU     (output) REAL
+*          The desired orthogonal matrix U.
+*
+*  CSV     (output) REAL
+*  SNV     (output) REAL
+*          The desired orthogonal matrix V.
+*
+*  CSQ     (output) REAL
+*  SNQ     (output) REAL
+*          The desired orthogonal matrix Q.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
+     $                   AVB21, AVB22, CSL, CSR, D, S1, S2, SNL,
+     $                   SNR, UA11R, UA22R, VB11R, VB22R, B, C, R, UA11,
+     $                   UA12, UA21, UA22, VB11, VB12, VB21, VB22
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARTG, SLASV2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      IF( UPPER ) THEN
+*
+*        Input matrices A and B are upper triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a b )
+*                                   ( 0 d )
+*
+         A = A1*B3
+         D = A3*B1
+         B = A2*B1 - A1*B2
+*
+*        The SVD of real 2-by-2 triangular C
+*
+*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL SLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
+     $        THEN
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11R = CSL*A1
+            UA12 = CSL*A2 + SNL*A3
+*
+            VB11R = CSR*B1
+            VB12 = CSR*B2 + SNR*B3
+*
+            AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
+            AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
+*
+*           zero (1,2) elements of U'*A and V'*B
+*
+            IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
+               IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
+     $             ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
+                  CALL SLARTG( -UA11R, UA12, CSQ, SNQ, R )
+               ELSE
+                  CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
+            END IF
+*
+            CSU = CSL
+            SNU = -SNL
+            CSV = CSR
+            SNV = -SNR
+*
+         ELSE
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -SNL*A1
+            UA22 = -SNL*A2 + CSL*A3
+*
+            VB21 = -SNR*B1
+            VB22 = -SNR*B2 + CSR*B3
+*
+            AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
+            AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
+*
+*           zero (2,2) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
+               IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
+     $             ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
+                  CALL SLARTG( -UA21, UA22, CSQ, SNQ, R )
+               ELSE
+                  CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNL
+            SNU = CSL
+            CSV = SNR
+            SNV = CSR
+*
+         END IF
+*
+      ELSE
+*
+*        Input matrices A and B are lower triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a 0 )
+*                                   ( c d )
+*
+         A = A1*B3
+         D = A3*B1
+         C = A2*B3 - A3*B2
+*
+*        The SVD of real 2-by-2 triangular C
+*
+*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL SLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
+     $        THEN
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -SNR*A1 + CSR*A2
+            UA22R = CSR*A3
+*
+            VB21 = -SNL*B1 + CSL*B2
+            VB22R = CSL*B3
+*
+            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
+            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
+*
+*           zero (2,1) elements of U'*A and V'*B.
+*
+            IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
+               IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
+     $             ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
+                  CALL SLARTG( UA22R, UA21, CSQ, SNQ, R )
+               ELSE
+                  CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
+            END IF
+*
+            CSU = CSR
+            SNU = -SNR
+            CSV = CSL
+            SNV = -SNL
+*
+         ELSE
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11 = CSR*A1 + SNR*A2
+            UA12 = SNR*A3
+*
+            VB11 = CSL*B1 + SNL*B2
+            VB12 = SNL*B3
+*
+            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
+            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
+*
+*           zero (1,1) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
+               IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
+     $             ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
+                  CALL SLARTG( UA12, UA11, CSQ, SNQ, R )
+               ELSE
+                  CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
+               END IF
+            ELSE
+               CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNR
+            SNU = CSR
+            CSV = SNL
+            SNV = CSL
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLAGS2
+*
+      END
diff --git a/SRC/slagtf.f b/SRC/slagtf.f
new file mode 100644
index 00000000..fb5df58c
--- /dev/null
+++ b/SRC/slagtf.f
@@ -0,0 +1,190 @@
+      SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+      REAL               LAMBDA, TOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IN( * )
+      REAL               A( * ), B( * ), C( * ), D( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
+*  tridiagonal matrix and lambda is a scalar, as
+*
+*     T - lambda*I = PLU,
+*
+*  where P is a permutation matrix, L is a unit lower tridiagonal matrix
+*  with at most one non-zero sub-diagonal elements per column and U is
+*  an upper triangular matrix with at most two non-zero super-diagonal
+*  elements per column.
+*
+*  The factorization is obtained by Gaussian elimination with partial
+*  pivoting and implicit row scaling.
+*
+*  The parameter LAMBDA is included in the routine so that SLAGTF may
+*  be used, in conjunction with SLAGTS, to obtain eigenvectors of T by
+*  inverse iteration.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix T.
+*
+*  A       (input/output) REAL array, dimension (N)
+*          On entry, A must contain the diagonal elements of T.
+*
+*          On exit, A is overwritten by the n diagonal elements of the
+*          upper triangular matrix U of the factorization of T.
+*
+*  LAMBDA  (input) REAL
+*          On entry, the scalar lambda.
+*
+*  B       (input/output) REAL array, dimension (N-1)
+*          On entry, B must contain the (n-1) super-diagonal elements of
+*          T.
+*
+*          On exit, B is overwritten by the (n-1) super-diagonal
+*          elements of the matrix U of the factorization of T.
+*
+*  C       (input/output) REAL array, dimension (N-1)
+*          On entry, C must contain the (n-1) sub-diagonal elements of
+*          T.
+*
+*          On exit, C is overwritten by the (n-1) sub-diagonal elements
+*          of the matrix L of the factorization of T.
+*
+*  TOL     (input) REAL
+*          On entry, a relative tolerance used to indicate whether or
+*          not the matrix (T - lambda*I) is nearly singular. TOL should
+*          normally be chose as approximately the largest relative error
+*          in the elements of T. For example, if the elements of T are
+*          correct to about 4 significant figures, then TOL should be
+*          set to about 5*10**(-4). If TOL is supplied as less than eps,
+*          where eps is the relative machine precision, then the value
+*          eps is used in place of TOL.
+*
+*  D       (output) REAL array, dimension (N-2)
+*          On exit, D is overwritten by the (n-2) second super-diagonal
+*          elements of the matrix U of the factorization of T.
+*
+*  IN      (output) INTEGER array, dimension (N)
+*          On exit, IN contains details of the permutation matrix P. If
+*          an interchange occurred at the kth step of the elimination,
+*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
+*          returns the smallest positive integer j such that
+*
+*             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
+*
+*          where norm( A(j) ) denotes the sum of the absolute values of
+*          the jth row of the matrix A. If no such j exists then IN(n)
+*          is returned as zero. If IN(n) is returned as positive, then a
+*          diagonal element of U is small, indicating that
+*          (T - lambda*I) is singular or nearly singular,
+*
+*  INFO    (output) INTEGER
+*          = 0   : successful exit
+*          .lt. 0: if INFO = -k, the kth argument had an illegal value
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            K
+      REAL               EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'SLAGTF', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      A( 1 ) = A( 1 ) - LAMBDA
+      IN( N ) = 0
+      IF( N.EQ.1 ) THEN
+         IF( A( 1 ).EQ.ZERO )
+     $      IN( 1 ) = 1
+         RETURN
+      END IF
+*
+      EPS = SLAMCH( 'Epsilon' )
+*
+      TL = MAX( TOL, EPS )
+      SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
+      DO 10 K = 1, N - 1
+         A( K+1 ) = A( K+1 ) - LAMBDA
+         SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
+         IF( K.LT.( N-1 ) )
+     $      SCALE2 = SCALE2 + ABS( B( K+1 ) )
+         IF( A( K ).EQ.ZERO ) THEN
+            PIV1 = ZERO
+         ELSE
+            PIV1 = ABS( A( K ) ) / SCALE1
+         END IF
+         IF( C( K ).EQ.ZERO ) THEN
+            IN( K ) = 0
+            PIV2 = ZERO
+            SCALE1 = SCALE2
+            IF( K.LT.( N-1 ) )
+     $         D( K ) = ZERO
+         ELSE
+            PIV2 = ABS( C( K ) ) / SCALE2
+            IF( PIV2.LE.PIV1 ) THEN
+               IN( K ) = 0
+               SCALE1 = SCALE2
+               C( K ) = C( K ) / A( K )
+               A( K+1 ) = A( K+1 ) - C( K )*B( K )
+               IF( K.LT.( N-1 ) )
+     $            D( K ) = ZERO
+            ELSE
+               IN( K ) = 1
+               MULT = A( K ) / C( K )
+               A( K ) = C( K )
+               TEMP = A( K+1 )
+               A( K+1 ) = B( K ) - MULT*TEMP
+               IF( K.LT.( N-1 ) ) THEN
+                  D( K ) = B( K+1 )
+                  B( K+1 ) = -MULT*D( K )
+               END IF
+               B( K ) = TEMP
+               C( K ) = MULT
+            END IF
+         END IF
+         IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
+     $      IN( N ) = K
+   10 CONTINUE
+      IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
+     $   IN( N ) = N
+*
+      RETURN
+*
+*     End of SLAGTF
+*
+      END
diff --git a/SRC/slagtm.f b/SRC/slagtm.f
new file mode 100644
index 00000000..cd58ceef
--- /dev/null
+++ b/SRC/slagtm.f
@@ -0,0 +1,190 @@
+      SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
+     $                   B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            LDB, LDX, N, NRHS
+      REAL               ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), D( * ), DL( * ), DU( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAGTM performs a matrix-vector product of the form
+*
+*     B := alpha * A * X + beta * B
+*
+*  where A is a tridiagonal matrix of order N, B and X are N by NRHS
+*  matrices, and alpha and beta are real scalars, each of which may be
+*  0., 1., or -1.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the operation applied to A.
+*          = 'N':  No transpose, B := alpha * A * X + beta * B
+*          = 'T':  Transpose,    B := alpha * A'* X + beta * B
+*          = 'C':  Conjugate transpose = Transpose
+*
+*  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 X and B.
+*
+*  ALPHA   (input) REAL
+*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 0.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of T.
+*
+*  D       (input) REAL array, dimension (N)
+*          The diagonal elements of T.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) super-diagonal elements of T.
+*
+*  X       (input) REAL array, dimension (LDX,NRHS)
+*          The N by NRHS matrix X.
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(N,1).
+*
+*  BETA    (input) REAL
+*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 1.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the N by NRHS matrix B.
+*          On exit, B is overwritten by the matrix expression
+*          B := alpha * A * X + beta * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(N,1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Multiply B by BETA if BETA.NE.1.
+*
+      IF( BETA.EQ.ZERO ) THEN
+         DO 20 J = 1, NRHS
+            DO 10 I = 1, N
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( BETA.EQ.-ONE ) THEN
+         DO 40 J = 1, NRHS
+            DO 30 I = 1, N
+               B( I, J ) = -B( I, J )
+   30       CONTINUE
+   40    CONTINUE
+      END IF
+*
+      IF( ALPHA.EQ.ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B + A*X
+*
+            DO 60 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 50 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DU( I )*X( I+1, J )
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE
+*
+*           Compute B := B + A'*X
+*
+            DO 80 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 70 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DL( I )*X( I+1, J )
+   70             CONTINUE
+               END IF
+   80       CONTINUE
+         END IF
+      ELSE IF( ALPHA.EQ.-ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B - A*X
+*
+            DO 100 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 90 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DU( I )*X( I+1, J )
+   90             CONTINUE
+               END IF
+  100       CONTINUE
+         ELSE
+*
+*           Compute B := B - A'*X
+*
+            DO 120 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 110 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DL( I )*X( I+1, J )
+  110             CONTINUE
+               END IF
+  120       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of SLAGTM
+*
+      END
diff --git a/SRC/slagts.f b/SRC/slagts.f
new file mode 100644
index 00000000..e2f43bee
--- /dev/null
+++ b/SRC/slagts.f
@@ -0,0 +1,304 @@
+      SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, JOB, N
+      REAL               TOL
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IN( * )
+      REAL               A( * ), B( * ), C( * ), D( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAGTS may be used to solve one of the systems of equations
+*
+*     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y,
+*
+*  where T is an n by n tridiagonal matrix, for x, following the
+*  factorization of (T - lambda*I) as
+*
+*     (T - lambda*I) = P*L*U ,
+*
+*  by routine SLAGTF. The choice of equation to be solved is
+*  controlled by the argument JOB, and in each case there is an option
+*  to perturb zero or very small diagonal elements of U, this option
+*  being intended for use in applications such as inverse iteration.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) INTEGER
+*          Specifies the job to be performed by SLAGTS as follows:
+*          =  1: The equations  (T - lambda*I)x = y  are to be solved,
+*                but diagonal elements of U are not to be perturbed.
+*          = -1: The equations  (T - lambda*I)x = y  are to be solved
+*                and, if overflow would otherwise occur, the diagonal
+*                elements of U are to be perturbed. See argument TOL
+*                below.
+*          =  2: The equations  (T - lambda*I)'x = y  are to be solved,
+*                but diagonal elements of U are not to be perturbed.
+*          = -2: The equations  (T - lambda*I)'x = y  are to be solved
+*                and, if overflow would otherwise occur, the diagonal
+*                elements of U are to be perturbed. See argument TOL
+*                below.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T.
+*
+*  A       (input) REAL array, dimension (N)
+*          On entry, A must contain the diagonal elements of U as
+*          returned from SLAGTF.
+*
+*  B       (input) REAL array, dimension (N-1)
+*          On entry, B must contain the first super-diagonal elements of
+*          U as returned from SLAGTF.
+*
+*  C       (input) REAL array, dimension (N-1)
+*          On entry, C must contain the sub-diagonal elements of L as
+*          returned from SLAGTF.
+*
+*  D       (input) REAL array, dimension (N-2)
+*          On entry, D must contain the second super-diagonal elements
+*          of U as returned from SLAGTF.
+*
+*  IN      (input) INTEGER array, dimension (N)
+*          On entry, IN must contain details of the matrix P as returned
+*          from SLAGTF.
+*
+*  Y       (input/output) REAL array, dimension (N)
+*          On entry, the right hand side vector y.
+*          On exit, Y is overwritten by the solution vector x.
+*
+*  TOL     (input/output) REAL
+*          On entry, with  JOB .lt. 0, TOL should be the minimum
+*          perturbation to be made to very small diagonal elements of U.
+*          TOL should normally be chosen as about eps*norm(U), where eps
+*          is the relative machine precision, but if TOL is supplied as
+*          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
+*          If  JOB .gt. 0  then TOL is not referenced.
+*
+*          On exit, TOL is changed as described above, only if TOL is
+*          non-positive on entry. Otherwise TOL is unchanged.
+*
+*  INFO    (output) INTEGER
+*          = 0   : successful exit
+*          .lt. 0: if INFO = -i, the i-th argument had an illegal value
+*          .gt. 0: overflow would occur when computing the INFO(th)
+*                  element of the solution vector x. This can only occur
+*                  when JOB is supplied as positive and either means
+*                  that a diagonal element of U is very small, or that
+*                  the elements of the right-hand side vector y are very
+*                  large.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            K
+      REAL               ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SIGN
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAGTS', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      EPS = SLAMCH( 'Epsilon' )
+      SFMIN = SLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SFMIN
+*
+      IF( JOB.LT.0 ) THEN
+         IF( TOL.LE.ZERO ) THEN
+            TOL = ABS( A( 1 ) )
+            IF( N.GT.1 )
+     $         TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
+            DO 10 K = 3, N
+               TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
+     $               ABS( D( K-2 ) ) )
+   10       CONTINUE
+            TOL = TOL*EPS
+            IF( TOL.EQ.ZERO )
+     $         TOL = EPS
+         END IF
+      END IF
+*
+      IF( ABS( JOB ).EQ.1 ) THEN
+         DO 20 K = 2, N
+            IF( IN( K-1 ).EQ.0 ) THEN
+               Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
+            ELSE
+               TEMP = Y( K-1 )
+               Y( K-1 ) = Y( K )
+               Y( K ) = TEMP - C( K-1 )*Y( K )
+            END IF
+   20    CONTINUE
+         IF( JOB.EQ.1 ) THEN
+            DO 30 K = N, 1, -1
+               IF( K.LE.N-2 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+               ELSE IF( K.EQ.N-1 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        INFO = K
+                        RETURN
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     INFO = K
+                     RETURN
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   30       CONTINUE
+         ELSE
+            DO 50 K = N, 1, -1
+               IF( K.LE.N-2 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+               ELSE IF( K.EQ.N-1 ) THEN
+                  TEMP = Y( K ) - B( K )*Y( K+1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               PERT = SIGN( TOL, AK )
+   40          CONTINUE
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        AK = AK + PERT
+                        PERT = 2*PERT
+                        GO TO 40
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     AK = AK + PERT
+                     PERT = 2*PERT
+                     GO TO 40
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   50       CONTINUE
+         END IF
+      ELSE
+*
+*        Come to here if  JOB = 2 or -2
+*
+         IF( JOB.EQ.2 ) THEN
+            DO 60 K = 1, N
+               IF( K.GE.3 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+               ELSE IF( K.EQ.2 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        INFO = K
+                        RETURN
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     INFO = K
+                     RETURN
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   60       CONTINUE
+         ELSE
+            DO 80 K = 1, N
+               IF( K.GE.3 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+               ELSE IF( K.EQ.2 ) THEN
+                  TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+               ELSE
+                  TEMP = Y( K )
+               END IF
+               AK = A( K )
+               PERT = SIGN( TOL, AK )
+   70          CONTINUE
+               ABSAK = ABS( AK )
+               IF( ABSAK.LT.ONE ) THEN
+                  IF( ABSAK.LT.SFMIN ) THEN
+                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+     $                    THEN
+                        AK = AK + PERT
+                        PERT = 2*PERT
+                        GO TO 70
+                     ELSE
+                        TEMP = TEMP*BIGNUM
+                        AK = AK*BIGNUM
+                     END IF
+                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+                     AK = AK + PERT
+                     PERT = 2*PERT
+                     GO TO 70
+                  END IF
+               END IF
+               Y( K ) = TEMP / AK
+   80       CONTINUE
+         END IF
+*
+         DO 90 K = N, 2, -1
+            IF( IN( K-1 ).EQ.0 ) THEN
+               Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
+            ELSE
+               TEMP = Y( K-1 )
+               Y( K-1 ) = Y( K )
+               Y( K ) = TEMP - C( K-1 )*Y( K )
+            END IF
+   90    CONTINUE
+      END IF
+*
+*     End of SLAGTS
+*
+      END
diff --git a/SRC/slagv2.f b/SRC/slagv2.f
new file mode 100644
index 00000000..bfe2f4d9
--- /dev/null
+++ b/SRC/slagv2.f
@@ -0,0 +1,287 @@
+      SUBROUTINE SLAGV2( 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
+      REAL               CSL, CSR, SNL, SNR
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
+     $                   B( LDB, * ), BETA( 2 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAGV2 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) REAL 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) REAL 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) REAL array, dimension (2)
+*  ALPHAI  (output) REAL array, dimension (2)
+*  BETA    (output) REAL 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) REAL
+*          The cosine of the left rotation matrix.
+*
+*  SNL     (output) REAL
+*          The sine of the left rotation matrix.
+*
+*  CSR     (output) REAL
+*          The cosine of the right rotation matrix.
+*
+*  SNR     (output) REAL
+*          The sine of the right rotation matrix.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
+     $                   R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
+     $                   WR2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAG2, SLARTG, SLASV2, SROT
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           SLAMCH, SLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      SAFMIN = SLAMCH( 'S' )
+      ULP = SLAMCH( '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 SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+         CSR = ONE
+         SNR = ZERO
+         CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+         CALL SROT( 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 SLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
+         SNR = -SNR
+         CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+         CALL SROT( 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 SLAG2( 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 = SLAPY2( H1, H2 )
+            QQ = SLAPY2( SCALE1*A( 2, 1 ), H3 )
+*
+            IF( RR.GT.QQ ) THEN
+*
+*              find right rotation matrix to zero 1,1 element of
+*              (sA - wB)
+*
+               CALL SLARTG( H2, H1, CSR, SNR, T )
+*
+            ELSE
+*
+*              find right rotation matrix to zero 2,1 element of
+*              (sA - wB)
+*
+               CALL SLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
+*
+            END IF
+*
+            SNR = -SNR
+            CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+            CALL SROT( 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 SLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
+*
+            ELSE
+*
+*              find left rotation matrix Q to zero out A(2,1)
+*
+               CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+*
+            END IF
+*
+            CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+            CALL SROT( 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 SLASV2( 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 SLASV2
+*
+            CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+            CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+            CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+            CALL SROT( 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 SLAGV2
+*
+      END
diff --git a/SRC/slahqr.f b/SRC/slahqr.f
new file mode 100644
index 00000000..e1259705
--- /dev/null
+++ b/SRC/slahqr.f
@@ -0,0 +1,501 @@
+      SUBROUTINE SLAHQR( 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 ..
+      REAL               H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     SLAHQR is an auxiliary routine called by SHSEQR to update the
+*     eigenvalues and Schur decomposition already computed by SHSEQR, 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). SLAHQR 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) REAL 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) REAL array, dimension (N)
+*     WI      (output) REAL array, dimension (N)
+*          The real and imaginary parts, respectively, of the computed
+*          eigenvalues ILO to IHI are stored in the corresponding
+*          elements of WR and WI. If two eigenvalues are computed as a
+*          complex conjugate pair, they are stored in consecutive
+*          elements of WR and WI, say the i-th and (i+1)th, with
+*          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
+*          eigenvalues are stored in the same order as on the diagonal
+*          of the Schur form returned in 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) REAL array, dimension (LDZ,N)
+*          If WANTZ is .TRUE., on entry Z must contain the current
+*          matrix Z of transformations accumulated by SHSEQR, 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, SLAHQR 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 SLAHQR 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 )
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0, TWO = 2.0e0 )
+      REAL               DAT1, DAT2
+      PARAMETER          ( DAT1 = 3.0e0 / 4.0e0, DAT2 = -0.4375e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 ..
+      REAL               V( 3 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLABAD, SLANV2, SLARFG, SROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 SCOPY( NR, H( K, K-1 ), 1, V, 1 )
+            CALL SLARFG( 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 SLANV2( 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 SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
+     $                    CS, SN )
+            CALL SROT( 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 SROT( 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 SLAHQR
+*
+      END
diff --git a/SRC/slahr2.f b/SRC/slahr2.f
new file mode 100644
index 00000000..4f8bf2ac
--- /dev/null
+++ b/SRC/slahr2.f
@@ -0,0 +1,238 @@
+      SUBROUTINE SLAHR2( 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 ..
+      REAL              A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAHR2 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 SGEHRD.
+*
+*  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) REAL 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) REAL array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) REAL array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) REAL 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 SLAHRD
+*  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 ..
+      REAL              ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, 
+     $                     ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL              EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMM, SGEMV, SLACPY,
+     $                   SLARFG, SSCAL, STRMM, STRMV
+*     ..
+*     .. 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 SGEMV( '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 SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL STRMV( 'Lower', 'Transpose', 'UNIT', 
+     $                  I-1, A( K+1, 1 ),
+     $                  LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL SGEMV( '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 STRMV( 'Upper', 'Transpose', 'NON-UNIT', 
+     $                  I-1, T, LDT,
+     $                  T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL SGEMV( '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 STRMV( 'Lower', 'NO TRANSPOSE', 
+     $                  'UNIT', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL SAXPY( 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 SLARFG( 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 SGEMV( '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 SGEMV( 'Transpose', N-K-I+1, I-1, 
+     $               ONE, A( K+I, 1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+         CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, 
+     $               Y( K+1, 1 ), LDY,
+     $               T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
+         CALL SSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
+*
+*        Compute T(1:I,I)
+*
+         CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL STRMV( '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 SLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
+      CALL STRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', 
+     $            'UNIT', K, NB,
+     $            ONE, A( K+1, 1 ), LDA, Y, LDY )
+      IF( N.GT.K+NB )
+     $   CALL SGEMM( '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 STRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', 
+     $            'NON-UNIT', K, NB,
+     $            ONE, T, LDT, Y, LDY )
+*
+      RETURN
+*
+*     End of SLAHR2
+*
+      END
diff --git a/SRC/slahrd.f b/SRC/slahrd.f
new file mode 100644
index 00000000..b5163a73
--- /dev/null
+++ b/SRC/slahrd.f
@@ -0,0 +1,207 @@
+      SUBROUTINE SLAHRD( 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 ..
+      REAL               A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAHRD 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 SLAHR2 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) REAL 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) REAL array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) REAL array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SLARFG, SSCAL, STRMV
+*     ..
+*     .. 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 SGEMV( '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 SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL STRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ),
+     $                  LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL SGEMV( '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 STRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT,
+     $                  T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL SGEMV( '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 STRMV( 'Lower', 'No transpose', 'Unit', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL SAXPY( 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 SLARFG( 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 SGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
+         CALL SGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+         CALL SGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
+     $               ONE, Y( 1, I ), 1 )
+         CALL SSCAL( N, TAU( I ), Y( 1, I ), 1 )
+*
+*        Compute T(1:i,i)
+*
+         CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL STRMV( '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 SLAHRD
+*
+      END
diff --git a/SRC/slaic1.f b/SRC/slaic1.f
new file mode 100644
index 00000000..78f161ff
--- /dev/null
+++ b/SRC/slaic1.f
@@ -0,0 +1,292 @@
+      SUBROUTINE SLAIC1( 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
+      REAL               C, GAMMA, S, SEST, SESTPR
+*     ..
+*     .. Array Arguments ..
+      REAL               W( J ), X( J )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAIC1 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 SLAIC1 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) REAL array, dimension (J)
+*          The j-vector x.
+*
+*  SEST    (input) REAL
+*          Estimated singular value of j by j matrix L
+*
+*  W       (input) REAL array, dimension (J)
+*          The j-vector w.
+*
+*  GAMMA   (input) REAL
+*          The diagonal element gamma.
+*
+*  SESTPR  (output) REAL
+*          Estimated singular value of (j+1) by (j+1) matrix Lhat.
+*
+*  S       (output) REAL
+*          Sine needed in forming xhat.
+*
+*  C       (output) REAL
+*          Cosine needed in forming xhat.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+      REAL               HALF, FOUR
+      PARAMETER          ( HALF = 0.5E0, FOUR = 4.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 ..
+      REAL               SDOT, SLAMCH
+      EXTERNAL           SDOT, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = SLAMCH( 'Epsilon' )
+      ALPHA = SDOT( 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 SLAIC1
+*
+      END
diff --git a/SRC/slaisnan.f b/SRC/slaisnan.f
new file mode 100644
index 00000000..ac4a8024
--- /dev/null
+++ b/SRC/slaisnan.f
@@ -0,0 +1,40 @@
+      FUNCTION SLAISNAN( SIN1, SIN2 )
+      LOGICAL SLAISNAN
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      REAL             SIN1, SIN2
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is not for general use.  It exists solely to avoid
+*  over-optimization in SISNAN.
+*
+*  SLAISNAN checks for NaNs by comparing its two arguments for
+*  inequality.  NaN is the only floating-point value where NaN != NaN
+*  returns .TRUE.  To check for NaNs, pass the same variable as both
+*  arguments.
+*
+*  A compiler must assume that the two arguments are
+*  not the same variable, and the test will not be optimized away.
+*  Interprocedural or whole-program optimization may delete this
+*  test.  The ISNAN functions will be replaced by the correct
+*  Fortran 03 intrinsic once the intrinsic is widely available.
+*
+*  Arguments
+*  =========
+*
+*  SIN1     (input) REAL
+*  SIN2     (input) REAL
+*          Two numbers to compare for inequality.
+*
+*  =====================================================================
+*
+*  .. Executable Statements ..
+      SLAISNAN = (SIN1.NE.SIN2)
+      END FUNCTION
diff --git a/SRC/slaln2.f b/SRC/slaln2.f
new file mode 100644
index 00000000..37422804
--- /dev/null
+++ b/SRC/slaln2.f
@@ -0,0 +1,507 @@
+      SUBROUTINE SLALN2( 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
+      REAL               CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLALN2 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 SLALN2, 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) REAL
+*          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) REAL
+*          The coefficient c, which A is multiplied by.
+*
+*  A       (input) REAL 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) REAL
+*          The 1,1 element in the diagonal matrix D.
+*
+*  D2      (input) REAL
+*          The 2,2 element in the diagonal matrix D.  Not used if NW=1.
+*
+*  B       (input) REAL 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) REAL
+*          The real part of the scalar "w".
+*
+*  WI      (input) REAL
+*          The imaginary part of the scalar "w".  Not used if NW=1.
+*
+*  X       (output) REAL array, dimension (LDX,NW)
+*          The NA x NW matrix X (unknowns), as computed by SLALN2.
+*          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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ICMAX, J
+      REAL               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            CSWAP( 4 ), RSWAP( 4 )
+      INTEGER            IPIVOT( 4, 4 )
+      REAL               CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Equivalences ..
+      EQUIVALENCE        ( CI( 1, 1 ), CIV( 1 ) ),
+     $                   ( CR( 1, 1 ), CRV( 1 ) )
+*     ..
+*     .. Data statements ..
+      DATA               CSWAP / .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*SLAMCH( '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 SLADIV( 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( CSWAP( 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 SLADIV( 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( CSWAP( 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 SLALN2
+*
+      END
diff --git a/SRC/slals0.f b/SRC/slals0.f
new file mode 100644
index 00000000..336a0265
--- /dev/null
+++ b/SRC/slals0.f
@@ -0,0 +1,377 @@
+      SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
+     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
+     $                   POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
+     $                   LDGNUM, NL, NR, NRHS, SQRE
+      REAL               C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
+      REAL               B( LDB, * ), BX( LDBX, * ), DIFL( * ),
+     $                   DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
+     $                   POLES( LDGNUM, * ), WORK( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLALS0 applies back the multiplying factors of either the left or the
+*  right singular vector matrix of a diagonal matrix appended by a row
+*  to the right hand side matrix B in solving the least squares problem
+*  using the divide-and-conquer SVD approach.
+*
+*  For the left singular vector matrix, three types of orthogonal
+*  matrices are involved:
+*
+*  (1L) Givens rotations: the number of such rotations is GIVPTR; the
+*       pairs of columns/rows they were applied to are stored in GIVCOL;
+*       and the C- and S-values of these rotations are stored in GIVNUM.
+*
+*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
+*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the
+*       J-th row.
+*
+*  (3L) The left singular vector matrix of the remaining matrix.
+*
+*  For the right singular vector matrix, four types of orthogonal
+*  matrices are involved:
+*
+*  (1R) The right singular vector matrix of the remaining matrix.
+*
+*  (2R) If SQRE = 1, one extra Givens rotation to generate the right
+*       null space.
+*
+*  (3R) The inverse transformation of (2L).
+*
+*  (4R) The inverse transformation of (1L).
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed in
+*         factored form:
+*         = 0: Left singular vector matrix.
+*         = 1: Right singular vector matrix.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block. NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block. NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) REAL array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M. On output, B contains
+*         the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B. LDB must be at least
+*         max(1,MAX( M, N ) ).
+*
+*  BX     (workspace) REAL array, dimension ( LDBX, NRHS )
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  PERM   (input) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) applied
+*         to the two blocks.
+*
+*  GIVPTR (input) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of rows/columns
+*         involved in a Givens rotation.
+*
+*  LDGCOL (input) INTEGER
+*         The leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value used in the
+*         corresponding Givens rotation.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of arrays DIFR, POLES and
+*         GIVNUM, must be at least K.
+*
+*  POLES  (input) REAL array, dimension ( LDGNUM, 2 )
+*         On entry, POLES(1:K, 1) contains the new singular
+*         values obtained from solving the secular equation, and
+*         POLES(1:K, 2) is an array containing the poles in the secular
+*         equation.
+*
+*  DIFL   (input) REAL array, dimension ( K ).
+*         On entry, DIFL(I) is the distance between I-th updated
+*         (undeflated) singular value and the I-th (undeflated) old
+*         singular value.
+*
+*  DIFR   (input) REAL array, dimension ( LDGNUM, 2 ).
+*         On entry, DIFR(I, 1) contains the distances between I-th
+*         updated (undeflated) singular value and the I+1-th
+*         (undeflated) old singular value. And DIFR(I, 2) is the
+*         normalizing factor for the I-th right singular vector.
+*
+*  Z      (input) REAL array, dimension ( K )
+*         Contain the components of the deflation-adjusted updating row
+*         vector.
+*
+*  K      (input) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  C      (input) REAL
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (input) REAL
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  WORK   (workspace) REAL array, dimension ( K )
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, M, N, NLP1
+      REAL               DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMV, SLACPY, SLASCL, SROT, SSCAL,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3, SNRM2
+      EXTERNAL           SLAMC3, SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      END IF
+*
+      N = NL + NR + 1
+*
+      IF( NRHS.LT.1 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -7
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -9
+      ELSE IF( GIVPTR.LT.0 ) THEN
+         INFO = -11
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -13
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -15
+      ELSE IF( K.LT.1 ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLALS0', -INFO )
+         RETURN
+      END IF
+*
+      M = N + SQRE
+      NLP1 = NL + 1
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+*
+*        Apply back orthogonal transformations from the left.
+*
+*        Step (1L): apply back the Givens rotations performed.
+*
+         DO 10 I = 1, GIVPTR
+            CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                 GIVNUM( I, 1 ) )
+   10    CONTINUE
+*
+*        Step (2L): permute rows of B.
+*
+         CALL SCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
+         DO 20 I = 2, N
+            CALL SCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
+   20    CONTINUE
+*
+*        Step (3L): apply the inverse of the left singular vector
+*        matrix to BX.
+*
+         IF( K.EQ.1 ) THEN
+            CALL SCOPY( NRHS, BX, LDBX, B, LDB )
+            IF( Z( 1 ).LT.ZERO ) THEN
+               CALL SSCAL( NRHS, NEGONE, B, LDB )
+            END IF
+         ELSE
+            DO 50 J = 1, K
+               DIFLJ = DIFL( J )
+               DJ = POLES( J, 1 )
+               DSIGJ = -POLES( J, 2 )
+               IF( J.LT.K ) THEN
+                  DIFRJ = -DIFR( J, 1 )
+                  DSIGJP = -POLES( J+1, 2 )
+               END IF
+               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
+     $              THEN
+                  WORK( J ) = ZERO
+               ELSE
+                  WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
+     $                        ( POLES( J, 2 )+DJ )
+               END IF
+               DO 30 I = 1, J - 1
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                           ( SLAMC3( POLES( I, 2 ), DSIGJ )-
+     $                           DIFLJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   30          CONTINUE
+               DO 40 I = J + 1, K
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                           ( SLAMC3( POLES( I, 2 ), DSIGJP )+
+     $                           DIFRJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   40          CONTINUE
+               WORK( 1 ) = NEGONE
+               TEMP = SNRM2( K, WORK, 1 )
+               CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
+     $                     B( J, 1 ), LDB )
+               CALL SLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
+     $                      LDB, INFO )
+   50       CONTINUE
+         END IF
+*
+*        Move the deflated rows of BX to B also.
+*
+         IF( K.LT.MAX( M, N ) )
+     $      CALL SLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
+     $                   B( K+1, 1 ), LDB )
+      ELSE
+*
+*        Apply back the right orthogonal transformations.
+*
+*        Step (1R): apply back the new right singular vector matrix
+*        to B.
+*
+         IF( K.EQ.1 ) THEN
+            CALL SCOPY( NRHS, B, LDB, BX, LDBX )
+         ELSE
+            DO 80 J = 1, K
+               DSIGJ = POLES( J, 2 )
+               IF( Z( J ).EQ.ZERO ) THEN
+                  WORK( J ) = ZERO
+               ELSE
+                  WORK( J ) = -Z( J ) / DIFL( J ) /
+     $                        ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
+               END IF
+               DO 60 I = 1, J - 1
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I+1,
+     $                           2 ) )-DIFR( I, 1 ) ) /
+     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+   60          CONTINUE
+               DO 70 I = J + 1, K
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     WORK( I ) = ZERO
+                  ELSE
+                     WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I,
+     $                           2 ) )-DIFL( I ) ) /
+     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+   70          CONTINUE
+               CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
+     $                     BX( J, 1 ), LDBX )
+   80       CONTINUE
+         END IF
+*
+*        Step (2R): if SQRE = 1, apply back the rotation that is
+*        related to the right null space of the subproblem.
+*
+         IF( SQRE.EQ.1 ) THEN
+            CALL SCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
+            CALL SROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
+         END IF
+         IF( K.LT.MAX( M, N ) )
+     $      CALL SLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
+     $                   LDBX )
+*
+*        Step (3R): permute rows of B.
+*
+         CALL SCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
+         IF( SQRE.EQ.1 ) THEN
+            CALL SCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
+         END IF
+         DO 90 I = 2, N
+            CALL SCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
+   90    CONTINUE
+*
+*        Step (4R): apply back the Givens rotations performed.
+*
+         DO 100 I = GIVPTR, 1, -1
+            CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                 -GIVNUM( I, 1 ) )
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SLALS0
+*
+      END
diff --git a/SRC/slalsa.f b/SRC/slalsa.f
new file mode 100644
index 00000000..3dd606bd
--- /dev/null
+++ b/SRC/slalsa.f
@@ -0,0 +1,362 @@
+      SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
+     $                   LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
+     $                   GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
+     $                   SMLSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+     $                   K( * ), PERM( LDGCOL, * )
+      REAL               B( LDB, * ), BX( LDBX, * ), C( * ),
+     $                   DIFL( LDU, * ), DIFR( LDU, * ),
+     $                   GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
+     $                   U( LDU, * ), VT( LDU, * ), WORK( * ),
+     $                   Z( LDU, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLALSA is an itermediate step in solving the least squares problem
+*  by computing the SVD of the coefficient matrix in compact form (The
+*  singular vectors are computed as products of simple orthorgonal
+*  matrices.).
+*
+*  If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector
+*  matrix of an upper bidiagonal matrix to the right hand side; and if
+*  ICOMPQ = 1, SLALSA applies the right singular vector matrix to the
+*  right hand side. The singular vector matrices were generated in
+*  compact form by SLALSA.
+*
+*  Arguments
+*  =========
+*
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether the left or the right singular vector
+*         matrix is involved.
+*         = 0: Left singular vector matrix
+*         = 1: Right singular vector matrix
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The row and column dimensions of the upper bidiagonal matrix.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) REAL array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M.
+*         On output, B contains the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,MAX( M, N ) ).
+*
+*  BX     (output) REAL array, dimension ( LDBX, NRHS )
+*         On exit, the result of applying the left or right singular
+*         vector matrix to B.
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  U      (input) REAL array, dimension ( LDU, SMLSIZ ).
+*         On entry, U contains the left singular vector matrices of all
+*         subproblems at the bottom level.
+*
+*  LDU    (input) INTEGER, LDU = > N.
+*         The leading dimension of arrays U, VT, DIFL, DIFR,
+*         POLES, GIVNUM, and Z.
+*
+*  VT     (input) REAL array, dimension ( LDU, SMLSIZ+1 ).
+*         On entry, VT' contains the right singular vector matrices of
+*         all subproblems at the bottom level.
+*
+*  K      (input) INTEGER array, dimension ( N ).
+*
+*  DIFL   (input) REAL array, dimension ( LDU, NLVL ).
+*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
+*
+*  DIFR   (input) REAL array, dimension ( LDU, 2 * NLVL ).
+*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
+*         distances between singular values on the I-th level and
+*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
+*         record the normalizing factors of the right singular vectors
+*         matrices of subproblems on I-th level.
+*
+*  Z      (input) REAL array, dimension ( LDU, NLVL ).
+*         On entry, Z(1, I) contains the components of the deflation-
+*         adjusted updating row vector for subproblems on the I-th
+*         level.
+*
+*  POLES  (input) REAL array, dimension ( LDU, 2 * NLVL ).
+*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
+*         singular values involved in the secular equations on the I-th
+*         level.
+*
+*  GIVPTR (input) INTEGER array, dimension ( N ).
+*         On entry, GIVPTR( I ) records the number of Givens
+*         rotations performed on the I-th problem on the computation
+*         tree.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
+*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
+*         locations of Givens rotations performed on the I-th level on
+*         the computation tree.
+*
+*  LDGCOL (input) INTEGER, LDGCOL = > N.
+*         The leading dimension of arrays GIVCOL and PERM.
+*
+*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).
+*         On entry, PERM(*, I) records permutations done on the I-th
+*         level of the computation tree.
+*
+*  GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).
+*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
+*         values of Givens rotations performed on the I-th level on the
+*         computation tree.
+*
+*  C      (input) REAL array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         C( I ) contains the C-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  S      (input) REAL array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         S( I ) contains the S-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  WORK   (workspace) REAL array.
+*         The dimension must be at least N.
+*
+*  IWORK  (workspace) INTEGER array.
+*         The dimension must be at least 3 * 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
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
+     $                   ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
+     $                   NR, NRF, NRP1, SQRE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, SLALS0, SLASDT, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.SMLSIZ ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -6
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -8
+      ELSE IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -19
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLALSA', -INFO )
+         RETURN
+      END IF
+*
+*     Book-keeping and  setting up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+*
+      CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     The following code applies back the left singular vector factors.
+*     For applying back the right singular vector factors, go to 50.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         GO TO 50
+      END IF
+*
+*     The nodes on the bottom level of the tree were solved
+*     by SLASDQ. The corresponding left and right singular vector
+*     matrices are in explicit form. First apply back the left
+*     singular vector matrices.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 10 I = NDB1, ND
+*
+*        IC : center row of each node
+*        NL : number of rows of left  subproblem
+*        NR : number of rows of right subproblem
+*        NLF: starting row of the left   subproblem
+*        NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLF = IC - NL
+         NRF = IC + 1
+         CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+         CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+     $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+   10 CONTINUE
+*
+*     Next copy the rows of B that correspond to unchanged rows
+*     in the bidiagonal matrix to BX.
+*
+      DO 20 I = 1, ND
+         IC = IWORK( INODE+I-1 )
+         CALL SCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
+   20 CONTINUE
+*
+*     Finally go through the left singular vector matrices of all
+*     the other subproblems bottom-up on the tree.
+*
+      J = 2**NLVL
+      SQRE = 0
+*
+      DO 40 LVL = NLVL, 1, -1
+         LVL2 = 2*LVL - 1
+*
+*        find the first node LF and last node LL on
+*        the current level LVL
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 30 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            J = J - 1
+            CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
+     $                   B( NLF, 1 ), LDB, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+     $                   INFO )
+   30    CONTINUE
+   40 CONTINUE
+      GO TO 90
+*
+*     ICOMPQ = 1: applying back the right singular vector factors.
+*
+   50 CONTINUE
+*
+*     First now go through the right singular vector matrices of all
+*     the tree nodes top-down.
+*
+      J = 0
+      DO 70 LVL = 1, NLVL
+         LVL2 = 2*LVL - 1
+*
+*        Find the first node LF and last node LL on
+*        the current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 60 I = LL, LF, -1
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            IF( I.EQ.LL ) THEN
+               SQRE = 0
+            ELSE
+               SQRE = 1
+            END IF
+            J = J + 1
+            CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
+     $                   BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+     $                   INFO )
+   60    CONTINUE
+   70 CONTINUE
+*
+*     The nodes on the bottom level of the tree were solved
+*     by SLASDQ. The corresponding right singular vector
+*     matrices are in explicit form. Apply them back.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 80 I = NDB1, ND
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLP1 = NL + 1
+         IF( I.EQ.ND ) THEN
+            NRP1 = NR
+         ELSE
+            NRP1 = NR + 1
+         END IF
+         NLF = IC - NL
+         NRF = IC + 1
+         CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+         CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+     $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+   80 CONTINUE
+*
+   90 CONTINUE
+*
+      RETURN
+*
+*     End of SLALSA
+*
+      END
diff --git a/SRC/slalsd.f b/SRC/slalsd.f
new file mode 100644
index 00000000..49e0ac25
--- /dev/null
+++ b/SRC/slalsd.f
@@ -0,0 +1,434 @@
+      SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
+     $                   RANK, WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               B( LDB, * ), D( * ), E( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLALSD uses the singular value decomposition of A to solve the least
+*  squares problem of finding X to minimize the Euclidean norm of each
+*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
+*  are N-by-NRHS. The solution X overwrites B.
+*
+*  The singular values of A smaller than RCOND times the largest
+*  singular value are treated as zero in solving the least squares
+*  problem; in this case a minimum norm solution is returned.
+*  The actual singular values are returned in D in ascending order.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  UPLO   (input) CHARACTER*1
+*         = 'U': D and E define an upper bidiagonal matrix.
+*         = 'L': D and E define a  lower bidiagonal matrix.
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The dimension of the  bidiagonal matrix.  N >= 0.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B. NRHS must be at least 1.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix. On exit, if INFO = 0, D contains its singular values.
+*
+*  E      (input/output) REAL array, dimension (N-1)
+*         Contains the super-diagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  B      (input/output) REAL array, dimension (LDB,NRHS)
+*         On input, B contains the right hand sides of the least
+*         squares problem. On output, B contains the solution X.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,N).
+*
+*  RCOND  (input) REAL
+*         The singular values of A less than or equal to RCOND times
+*         the largest singular value are treated as zero in solving
+*         the least squares problem. If RCOND is negative,
+*         machine precision is used instead.
+*         For example, if diag(S)*X=B were the least squares problem,
+*         where diag(S) is a diagonal matrix of singular values, the
+*         solution would be X(i) = B(i) / S(i) if S(i) is greater than
+*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
+*         RCOND*max(S).
+*
+*  RANK   (output) INTEGER
+*         The number of singular values of A greater than RCOND times
+*         the largest singular value.
+*
+*  WORK   (workspace) REAL array, dimension at least
+*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
+*         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
+*
+*  IWORK  (workspace) INTEGER array, dimension at least
+*         (3*N*NLVL + 11*N)
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*         > 0:  The algorithm failed to compute an singular value while
+*               working on the submatrix lying in rows and columns
+*               INFO/(N+1) through MOD(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
+     $                   GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
+     $                   NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
+     $                   SMLSZP, SQRE, ST, ST1, U, VT, Z
+      REAL               CS, EPS, ORGNRM, R, RCND, SN, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLANST
+      EXTERNAL           ISAMAX, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, SLACPY, SLALSA, SLARTG, SLASCL,
+     $                   SLASDA, SLASDQ, SLASET, SLASRT, SROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, REAL, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLALSD', -INFO )
+         RETURN
+      END IF
+*
+      EPS = SLAMCH( 'Epsilon' )
+*
+*     Set up the tolerance.
+*
+      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
+         RCND = EPS
+      ELSE
+         RCND = RCOND
+      END IF
+*
+      RANK = 0
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         IF( D( 1 ).EQ.ZERO ) THEN
+            CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
+         ELSE
+            RANK = 1
+            CALL SLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
+            D( 1 ) = ABS( D( 1 ) )
+         END IF
+         RETURN
+      END IF
+*
+*     Rotate the matrix if it is lower bidiagonal.
+*
+      IF( UPLO.EQ.'L' ) THEN
+         DO 10 I = 1, N - 1
+            CALL SLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( NRHS.EQ.1 ) THEN
+               CALL SROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
+            ELSE
+               WORK( I*2-1 ) = CS
+               WORK( I*2 ) = SN
+            END IF
+   10    CONTINUE
+         IF( NRHS.GT.1 ) THEN
+            DO 30 I = 1, NRHS
+               DO 20 J = 1, N - 1
+                  CS = WORK( J*2-1 )
+                  SN = WORK( J*2 )
+                  CALL SROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
+   20          CONTINUE
+   30       CONTINUE
+         END IF
+      END IF
+*
+*     Scale.
+*
+      NM1 = N - 1
+      ORGNRM = SLANST( 'M', N, D, E )
+      IF( ORGNRM.EQ.ZERO ) THEN
+         CALL SLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
+         RETURN
+      END IF
+*
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
+*
+*     If N is smaller than the minimum divide size SMLSIZ, then solve
+*     the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         NWORK = 1 + N*N
+         CALL SLASET( 'A', N, N, ZERO, ONE, WORK, N )
+         CALL SLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
+     $                LDB, WORK( NWORK ), INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
+         DO 40 I = 1, N
+            IF( D( I ).LE.TOL ) THEN
+               CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+            ELSE
+               CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
+     $                      LDB, INFO )
+               RANK = RANK + 1
+            END IF
+   40    CONTINUE
+         CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
+     $               WORK( NWORK ), N )
+         CALL SLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
+*
+*        Unscale.
+*
+         CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+         CALL SLASRT( 'D', N, D, INFO )
+         CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+         RETURN
+      END IF
+*
+*     Book-keeping and setting up some constants.
+*
+      NLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+*
+      SMLSZP = SMLSIZ + 1
+*
+      U = 1
+      VT = 1 + SMLSIZ*N
+      DIFL = VT + SMLSZP*N
+      DIFR = DIFL + NLVL*N
+      Z = DIFR + NLVL*N*2
+      C = Z + NLVL*N
+      S = C + N
+      POLES = S + N
+      GIVNUM = POLES + 2*NLVL*N
+      BX = GIVNUM + 2*NLVL*N
+      NWORK = BX + N*NRHS
+*
+      SIZEI = 1 + N
+      K = SIZEI + N
+      GIVPTR = K + N
+      PERM = GIVPTR + N
+      GIVCOL = PERM + NLVL*N
+      IWK = GIVCOL + NLVL*N*2
+*
+      ST = 1
+      SQRE = 0
+      ICMPQ1 = 1
+      ICMPQ2 = 0
+      NSUB = 0
+*
+      DO 50 I = 1, N
+         IF( ABS( D( I ) ).LT.EPS ) THEN
+            D( I ) = SIGN( EPS, D( I ) )
+         END IF
+   50 CONTINUE
+*
+      DO 60 I = 1, NM1
+         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+            NSUB = NSUB + 1
+            IWORK( NSUB ) = ST
+*
+*           Subproblem found. First determine its size and then
+*           apply divide and conquer on it.
+*
+            IF( I.LT.NM1 ) THEN
+*
+*              A subproblem with E(I) small for I < NM1.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+*              A subproblem with E(NM1) not too small but I = NM1.
+*
+               NSIZE = N - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE
+*
+*              A subproblem with E(NM1) small. This implies an
+*              1-by-1 subproblem at D(N), which is not solved
+*              explicitly.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+               NSUB = NSUB + 1
+               IWORK( NSUB ) = N
+               IWORK( SIZEI+NSUB-1 ) = 1
+               CALL SCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
+            END IF
+            ST1 = ST - 1
+            IF( NSIZE.EQ.1 ) THEN
+*
+*              This is a 1-by-1 subproblem and is not solved
+*              explicitly.
+*
+               CALL SCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
+            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+*              This is a small subproblem and is solved by SLASDQ.
+*
+               CALL SLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+     $                      WORK( VT+ST1 ), N )
+               CALL SLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
+     $                      E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
+     $                      N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+               CALL SLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
+     $                      WORK( BX+ST1 ), N )
+            ELSE
+*
+*              A large problem. Solve it using divide and conquer.
+*
+               CALL SLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
+     $                      E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
+     $                      IWORK( K+ST1 ), WORK( DIFL+ST1 ),
+     $                      WORK( DIFR+ST1 ), WORK( Z+ST1 ),
+     $                      WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
+     $                      IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
+     $                      WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
+     $                      WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
+     $                      INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+               BXST = BX + ST1
+               CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
+     $                      LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
+     $                      WORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                      WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+     $                      WORK( Z+ST1 ), WORK( POLES+ST1 ),
+     $                      IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                      IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+     $                      WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+     $                      IWORK( IWK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+            END IF
+            ST = I + 1
+         END IF
+   60 CONTINUE
+*
+*     Apply the singular values and treat the tiny ones as zero.
+*
+      TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
+*
+      DO 70 I = 1, N
+*
+*        Some of the elements in D can be negative because 1-by-1
+*        subproblems were not solved explicitly.
+*
+         IF( ABS( D( I ) ).LE.TOL ) THEN
+            CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
+         ELSE
+            RANK = RANK + 1
+            CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
+     $                   WORK( BX+I-1 ), N, INFO )
+         END IF
+         D( I ) = ABS( D( I ) )
+   70 CONTINUE
+*
+*     Now apply back the right singular vectors.
+*
+      ICMPQ2 = 1
+      DO 80 I = 1, NSUB
+         ST = IWORK( I )
+         ST1 = ST - 1
+         NSIZE = IWORK( SIZEI+I-1 )
+         BXST = BX + ST1
+         IF( NSIZE.EQ.1 ) THEN
+            CALL SCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
+         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+            CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                  WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
+     $                  B( ST, 1 ), LDB )
+         ELSE
+            CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
+     $                   B( ST, 1 ), LDB, WORK( U+ST1 ), N,
+     $                   WORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                   WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+     $                   WORK( Z+ST1 ), WORK( POLES+ST1 ),
+     $                   IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                   IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+     $                   WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+     $                   IWORK( IWK ), INFO )
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+         END IF
+   80 CONTINUE
+*
+*     Unscale and sort the singular values.
+*
+      CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+      CALL SLASRT( 'D', N, D, INFO )
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+      RETURN
+*
+*     End of SLALSD
+*
+      END
diff --git a/SRC/slamrg.f b/SRC/slamrg.f
new file mode 100644
index 00000000..a2b554a6
--- /dev/null
+++ b/SRC/slamrg.f
@@ -0,0 +1,103 @@
+      SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N1, N2, STRD1, STRD2
+*     ..
+*     .. Array Arguments ..
+      INTEGER            INDEX( * )
+      REAL               A( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMRG will create a permutation list which will merge the elements
+*  of A (which is composed of two independently sorted sets) into a
+*  single set which is sorted in ascending order.
+*
+*  Arguments
+*  =========
+*
+*  N1     (input) INTEGER
+*  N2     (input) INTEGER
+*         These arguements contain the respective lengths of the two
+*         sorted lists to be merged.
+*
+*  A      (input) REAL array, dimension (N1+N2)
+*         The first N1 elements of A contain a list of numbers which
+*         are sorted in either ascending or descending order.  Likewise
+*         for the final N2 elements.
+*
+*  STRD1  (input) INTEGER
+*  STRD2  (input) INTEGER
+*         These are the strides to be taken through the array A.
+*         Allowable strides are 1 and -1.  They indicate whether a
+*         subset of A is sorted in ascending (STRDx = 1) or descending
+*         (STRDx = -1) order.
+*
+*  INDEX  (output) INTEGER array, dimension (N1+N2)
+*         On exit this array will contain a permutation such that
+*         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
+*         sorted in ascending order.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IND1, IND2, N1SV, N2SV
+*     ..
+*     .. Executable Statements ..
+*
+      N1SV = N1
+      N2SV = N2
+      IF( STRD1.GT.0 ) THEN
+         IND1 = 1
+      ELSE
+         IND1 = N1
+      END IF
+      IF( STRD2.GT.0 ) THEN
+         IND2 = 1 + N1
+      ELSE
+         IND2 = N1 + N2
+      END IF
+      I = 1
+*     while ( (N1SV > 0) & (N2SV > 0) )
+   10 CONTINUE
+      IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
+         IF( A( IND1 ).LE.A( IND2 ) ) THEN
+            INDEX( I ) = IND1
+            I = I + 1
+            IND1 = IND1 + STRD1
+            N1SV = N1SV - 1
+         ELSE
+            INDEX( I ) = IND2
+            I = I + 1
+            IND2 = IND2 + STRD2
+            N2SV = N2SV - 1
+         END IF
+         GO TO 10
+      END IF
+*     end while
+      IF( N1SV.EQ.0 ) THEN
+         DO 20 N1SV = 1, N2SV
+            INDEX( I ) = IND2
+            I = I + 1
+            IND2 = IND2 + STRD2
+   20    CONTINUE
+      ELSE
+*     N2SV .EQ. 0
+         DO 30 N2SV = 1, N1SV
+            INDEX( I ) = IND1
+            I = I + 1
+            IND1 = IND1 + STRD1
+   30    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SLAMRG
+*
+      END
diff --git a/SRC/slaneg.f b/SRC/slaneg.f
new file mode 100644
index 00000000..c9d91e2b
--- /dev/null
+++ b/SRC/slaneg.f
@@ -0,0 +1,164 @@
+      FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )
+      IMPLICIT NONE
+      INTEGER SLANEG
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N, R
+      REAL               PIVMIN, SIGMA
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), LLD( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANEG computes the Sturm count, the number of negative pivots
+*  encountered while factoring tridiagonal T - sigma I = L D L^T.
+*  This implementation works directly on the factors without forming
+*  the tridiagonal matrix T.  The Sturm count is also the number of
+*  eigenvalues of T less than sigma.
+*
+*  This routine is called from SLARRB.
+*
+*  The current routine does not use the PIVMIN parameter but rather
+*  requires IEEE-754 propagation of Infinities and NaNs.  This
+*  routine also has no input range restrictions but does require
+*  default exception handling such that x/0 produces Inf when x is
+*  non-zero, and Inf/Inf produces NaN.  For more information, see:
+*
+*    Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
+*    Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
+*    Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624
+*    (Tech report version in LAWN 172 with the same title.)
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.
+*
+*  D       (input) REAL             array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D.
+*
+*  LLD     (input) REAL             array, dimension (N-1)
+*          The (N-1) elements L(i)*L(i)*D(i).
+*
+*  SIGMA   (input) REAL            
+*          Shift amount in T - sigma I = L D L^T.
+*
+*  PIVMIN  (input) REAL            
+*          The minimum pivot in the Sturm sequence.  May be used
+*          when zero pivots are encountered on non-IEEE-754
+*          architectures.
+*
+*  R       (input) INTEGER
+*          The twist index for the twisted factorization that is used
+*          for the negcount.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*     Jason Riedy, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER        ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     Some architectures propagate Infinities and NaNs very slowly, so
+*     the code computes counts in BLKLEN chunks.  Then a NaN can
+*     propagate at most BLKLEN columns before being detected.  This is
+*     not a general tuning parameter; it needs only to be just large
+*     enough that the overhead is tiny in common cases.
+      INTEGER BLKLEN
+      PARAMETER ( BLKLEN = 128 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BJ, J, NEG1, NEG2, NEGCNT
+      REAL               BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
+      LOGICAL SAWNAN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MIN, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL SISNAN
+      EXTERNAL SISNAN
+*     ..
+*     .. Executable Statements ..
+
+      NEGCNT = 0
+
+*     I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+      T = -SIGMA
+      DO 210 BJ = 1, R-1, BLKLEN
+         NEG1 = 0
+         BSAV = T
+         DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+            DPLUS = D( J ) + T
+            IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+            TMP = T / DPLUS
+            T = TMP * LLD( J ) - SIGMA
+ 21      CONTINUE
+         SAWNAN = SISNAN( T )
+*     Run a slower version of the above loop if a NaN is detected.
+*     A NaN should occur only with a zero pivot after an infinite
+*     pivot.  In that case, substituting 1 for T/DPLUS is the
+*     correct limit.
+         IF( SAWNAN ) THEN
+            NEG1 = 0
+            T = BSAV
+            DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+               DPLUS = D( J ) + T
+               IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+               TMP = T / DPLUS
+               IF (SISNAN(TMP)) TMP = ONE
+               T = TMP * LLD(J) - SIGMA
+ 22         CONTINUE
+         END IF
+         NEGCNT = NEGCNT + NEG1
+ 210  CONTINUE
+*
+*     II) lower part: L D L^T - SIGMA I = U- D- U-^T
+      P = D( N ) - SIGMA
+      DO 230 BJ = N-1, R, -BLKLEN
+         NEG2 = 0
+         BSAV = P
+         DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+            DMINUS = LLD( J ) + P
+            IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+            TMP = P / DMINUS
+            P = TMP * D( J ) - SIGMA
+ 23      CONTINUE
+         SAWNAN = SISNAN( P )
+*     As above, run a slower version that substitutes 1 for Inf/Inf.
+*
+         IF( SAWNAN ) THEN
+            NEG2 = 0
+            P = BSAV
+            DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+               DMINUS = LLD( J ) + P
+               IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+               TMP = P / DMINUS
+               IF (SISNAN(TMP)) TMP = ONE
+               P = TMP * D(J) - SIGMA
+ 24         CONTINUE
+         END IF
+         NEGCNT = NEGCNT + NEG2
+ 230  CONTINUE
+*
+*     III) Twist index
+*       T was shifted by SIGMA initially.
+      GAMMA = (T + SIGMA) + P
+      IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+      SLANEG = NEGCNT
+      END
diff --git a/SRC/slangb.f b/SRC/slangb.f
new file mode 100644
index 00000000..dd9d8ae9
--- /dev/null
+++ b/SRC/slangb.f
@@ -0,0 +1,154 @@
+      REAL             FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB,
+     $                 WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            KL, KU, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANGB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  SLANGB returns the value
+*
+*     SLANGB = ( 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 SLANGB as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, SLANGB is
+*          set to zero.
+*
+*  KL      (input) INTEGER
+*          The number of sub-diagonals of the matrix A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of super-diagonals of the matrix A.  KU >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, K, L
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               VALUE = MAX( VALUE, ABS( AB( 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               SUM = SUM + ABS( AB( 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
+            K = KU + 1 - J
+            DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
+               WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, N
+            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
+            L = MAX( 1, J-KU )
+            K = KU + 1 - J + L
+            CALL SLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANGB = VALUE
+      RETURN
+*
+*     End of SLANGB
+*
+      END
diff --git a/SRC/slange.f b/SRC/slange.f
new file mode 100644
index 00000000..c7c122ee
--- /dev/null
+++ b/SRC/slange.f
@@ -0,0 +1,144 @@
+      REAL             FUNCTION SLANGE( 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 ..
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANGE  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
+*  ===========
+*
+*  SLANGE returns the value
+*
+*     SLANGE = ( 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 SLANGE as described
+*          above.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.  When M = 0,
+*          SLANGE is set to zero.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.  When N = 0,
+*          SLANGE is set to zero.
+*
+*  A       (input) REAL 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 SLASSQ( M, A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANGE = VALUE
+      RETURN
+*
+*     End of SLANGE
+*
+      END
diff --git a/SRC/slangt.f b/SRC/slangt.f
new file mode 100644
index 00000000..efd701f7
--- /dev/null
+++ b/SRC/slangt.f
@@ -0,0 +1,141 @@
+      REAL             FUNCTION SLANGT( NORM, N, DL, D, DU )
+*
+*  -- 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 ..
+      REAL               D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANGT  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  real tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  SLANGT returns the value
+*
+*     SLANGT = ( 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 SLANGT as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, SLANGT is
+*          set to zero.
+*
+*  DL      (input) REAL array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of A.
+*
+*  D       (input) REAL array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) REAL array, dimension (N-1)
+*          The (n-1) super-diagonal elements of A.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               ANORM, SCALE, SUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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( DL( I ) ) )
+            ANORM = MAX( ANORM, ABS( D( I ) ) )
+            ANORM = MAX( ANORM, ABS( DU( I ) ) )
+   10    CONTINUE
+      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
+*
+*        Find norm1(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
+     $              ABS( D( N ) )+ABS( DU( N-1 ) ) )
+            DO 20 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
+     $                 ABS( DU( I-1 ) ) )
+   20       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
+     $              ABS( D( N ) )+ABS( DL( N-1 ) ) )
+            DO 30 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
+     $                 ABS( DL( I-1 ) ) )
+   30       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         CALL SLASSQ( N, D, 1, SCALE, SUM )
+         IF( N.GT.1 ) THEN
+            CALL SLASSQ( N-1, DL, 1, SCALE, SUM )
+            CALL SLASSQ( N-1, DU, 1, SCALE, SUM )
+         END IF
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANGT = ANORM
+      RETURN
+*
+*     End of SLANGT
+*
+      END
diff --git a/SRC/slanhs.f b/SRC/slanhs.f
new file mode 100644
index 00000000..6c3e370e
--- /dev/null
+++ b/SRC/slanhs.f
@@ -0,0 +1,141 @@
+      REAL             FUNCTION SLANHS( 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 ..
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANHS  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
+*  ===========
+*
+*  SLANHS returns the value
+*
+*     SLANHS = ( 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 SLANHS as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, SLANHS is
+*          set to zero.
+*
+*  A       (input) REAL 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANHS = VALUE
+      RETURN
+*
+*     End of SLANHS
+*
+      END
diff --git a/SRC/slansb.f b/SRC/slansb.f
new file mode 100644
index 00000000..04f8ec04
--- /dev/null
+++ b/SRC/slansb.f
@@ -0,0 +1,186 @@
+      REAL             FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB,
+     $                 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANSB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n symmetric band matrix A,  with k super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  SLANSB returns the value
+*
+*     SLANSB = ( 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 SLANSB as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          band matrix A is supplied.
+*          = 'U':  Upper triangular part is supplied
+*          = 'L':  Lower triangular part is supplied
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, SLANSB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals or sub-diagonals of the
+*          band matrix A.  K >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first K+1 rows of AB.  The j-th column of A is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = MAX( K+2-J, 1 ), K + 1
+                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               DO 30 I = 1, MIN( N+1-J, K+1 )
+                  VALUE = MAX( VALUE, ABS( AB( 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
+               L = K + 1 - J
+               DO 50 I = MAX( 1, J-K ), J - 1
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( AB( K+1, J ) )
+   60       CONTINUE
+            DO 70 I = 1, N
+               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( AB( 1, J ) )
+               L = 1 - J
+               DO 90 I = J + 1, MIN( N, J+K )
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               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( K.GT.0 ) THEN
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 110 J = 2, N
+                  CALL SLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  110          CONTINUE
+               L = K + 1
+            ELSE
+               DO 120 J = 1, N - 1
+                  CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                         SUM )
+  120          CONTINUE
+               L = 1
+            END IF
+            SUM = 2*SUM
+         ELSE
+            L = 1
+         END IF
+         CALL SLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANSB = VALUE
+      RETURN
+*
+*     End of SLANSB
+*
+      END
diff --git a/SRC/slansp.f b/SRC/slansp.f
new file mode 100644
index 00000000..a0a86958
--- /dev/null
+++ b/SRC/slansp.f
@@ -0,0 +1,196 @@
+      REAL             FUNCTION SLANSP( 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 ..
+      REAL               AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANSP  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
+*  ===========
+*
+*  SLANSP returns the value
+*
+*     SLANSP = ( 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 SLANSP 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, SLANSP is
+*          set to zero.
+*
+*  AP      (input) REAL 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, K
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+               K = K + J
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL SLASSQ( 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
+*
+      SLANSP = VALUE
+      RETURN
+*
+*     End of SLANSP
+*
+      END
diff --git a/SRC/slanst.f b/SRC/slanst.f
new file mode 100644
index 00000000..836752ec
--- /dev/null
+++ b/SRC/slanst.f
@@ -0,0 +1,124 @@
+      REAL             FUNCTION SLANST( 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 ..
+      REAL               D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANST  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
+*  ===========
+*
+*  SLANST returns the value
+*
+*     SLANST = ( 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 SLANST as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, SLANST is
+*          set to zero.
+*
+*  D       (input) REAL array, dimension (N)
+*          The diagonal elements of A.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) sub-diagonal or super-diagonal elements of A.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               ANORM, SCALE, SUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 SLASSQ( N-1, E, 1, SCALE, SUM )
+            SUM = 2*SUM
+         END IF
+         CALL SLASSQ( N, D, 1, SCALE, SUM )
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANST = ANORM
+      RETURN
+*
+*     End of SLANST
+*
+      END
diff --git a/SRC/slansy.f b/SRC/slansy.f
new file mode 100644
index 00000000..ae260306
--- /dev/null
+++ b/SRC/slansy.f
@@ -0,0 +1,173 @@
+      REAL             FUNCTION SLANSY( 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 ..
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANSY  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
+*  ===========
+*
+*  SLANSY returns the value
+*
+*     SLANSY = ( 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 SLANSY 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, SLANSY is
+*          set to zero.
+*
+*  A       (input) REAL 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 SLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL SLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+  120       CONTINUE
+         END IF
+         SUM = 2*SUM
+         CALL SLASSQ( N, A, LDA+1, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANSY = VALUE
+      RETURN
+*
+*     End of SLANSY
+*
+      END
diff --git a/SRC/slantb.f b/SRC/slantb.f
new file mode 100644
index 00000000..8ba88926
--- /dev/null
+++ b/SRC/slantb.f
@@ -0,0 +1,284 @@
+      REAL             FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB,
+     $                 LDAB, 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANTB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.
+*
+*  Description
+*  ===========
+*
+*  SLANTB returns the value
+*
+*     SLANTB = ( 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 SLANTB as described
+*          above.
+*
+*  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.  When N = 0, SLANTB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.
+*          K >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first k+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*          Note that when DIAG = 'U', the elements of the array AB
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+1.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, L
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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))).
+*
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = MAX( K+2-J, 1 ), K
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = 2, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   30             CONTINUE
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = MAX( K+2-J, 1 ), K + 1
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = 1, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( 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 ) THEN
+                  SUM = ONE
+                  DO 90 I = MAX( K+2-J, 1 ), K
+                     SUM = SUM + ABS( AB( I, J ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = MAX( K+2-J, 1 ), K + 1
+                     SUM = SUM + ABS( AB( I, J ) )
+  100             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = 2, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = 1, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  130             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  L = K + 1 - J
+                  DO 160 I = MAX( 1, J-K ), J - 1
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  160             CONTINUE
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  L = K + 1 - J
+                  DO 190 I = MAX( 1, J-K ), J
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  L = 1 - J
+                  DO 220 I = J + 1, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  L = 1 - J
+                  DO 250 I = J, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 280 J = 2, N
+                     CALL SLASSQ( MIN( J-1, K ),
+     $                            AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
+     $                            SUM )
+  280             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 290 J = 1, N
+                  CALL SLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 300 J = 1, N - 1
+                     CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                            SUM )
+  300             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 310 J = 1, N
+                  CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANTB = VALUE
+      RETURN
+*
+*     End of SLANTB
+*
+      END
diff --git a/SRC/slantp.f b/SRC/slantp.f
new file mode 100644
index 00000000..329e2270
--- /dev/null
+++ b/SRC/slantp.f
@@ -0,0 +1,285 @@
+      REAL             FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, 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            N
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANTP  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  triangular matrix A, supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  SLANTP returns the value
+*
+*     SLANTP = ( 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 SLANTP as described
+*          above.
+*
+*  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.  When N = 0, SLANTP is
+*          set to zero.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          Note that when DIAG = 'U', the elements of the array AP
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, K
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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))).
+*
+         K = 1
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = K, K + J - 2
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10             CONTINUE
+                  K = K + J
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = K + 1, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   30             CONTINUE
+                  K = K + N - J + 1
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = K, K + J - 1
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   50             CONTINUE
+                  K = K + J
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = K, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   70             CONTINUE
+                  K = K + N - J + 1
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         K = 1
+         UDIAG = LSAME( DIAG, 'U' )
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 90 I = K, K + J - 2
+                     SUM = SUM + ABS( AP( I ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = K, K + J - 1
+                     SUM = SUM + ABS( AP( I ) )
+  100             CONTINUE
+               END IF
+               K = K + J
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = K + 1, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = K, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  130             CONTINUE
+               END IF
+               K = K + N - J + 1
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         K = 1
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  DO 160 I = 1, J - 1
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  160             CONTINUE
+                  K = K + 1
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  DO 190 I = 1, J
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  K = K + 1
+                  DO 220 I = J + 1, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  DO 250 I = J, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         VALUE = ZERO
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 280 J = 2, N
+                  CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  280          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 290 J = 1, N
+                  CALL SLASSQ( J, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 300 J = 1, N - 1
+                  CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  300          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 310 J = 1, N
+                  CALL SLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANTP = VALUE
+      RETURN
+*
+*     End of SLANTP
+*
+      END
diff --git a/SRC/slantr.f b/SRC/slantr.f
new file mode 100644
index 00000000..8573310a
--- /dev/null
+++ b/SRC/slantr.f
@@ -0,0 +1,276 @@
+      REAL             FUNCTION SLANTR( 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 ..
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANTR  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
+*  ===========
+*
+*  SLANTR returns the value
+*
+*     SLANTR = ( 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 SLANTR 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, SLANTR 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, SLANTR is set to zero.
+*
+*  A       (input) REAL 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) REAL array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J
+      REAL               SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASSQ
+*     ..
+*     .. 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 SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
+  290          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 300 J = 1, N
+                  CALL SLASSQ( 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 SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 320 J = 1, N
+                  CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
+  320          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      SLANTR = VALUE
+      RETURN
+*
+*     End of SLANTR
+*
+      END
diff --git a/SRC/slanv2.f b/SRC/slanv2.f
new file mode 100644
index 00000000..c301a2c2
--- /dev/null
+++ b/SRC/slanv2.f
@@ -0,0 +1,205 @@
+      SUBROUTINE SLANV2( 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 ..
+      REAL               A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLANV2 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) REAL            
+*  B       (input/output) REAL            
+*  C       (input/output) REAL            
+*  D       (input/output) REAL            
+*          On entry, the elements of the input matrix.
+*          On exit, they are overwritten by the elements of the
+*          standardised Schur form.
+*
+*  RT1R    (output) REAL 
+*  RT1I    (output) REAL            
+*  RT2R    (output) REAL            
+*  RT2I    (output) REAL            
+*          The real and imaginary parts of the eigenvalues. If the
+*          eigenvalues are a complex conjugate pair, RT1I > 0.
+*
+*  CS      (output) REAL            
+*  SN      (output) REAL            
+*          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 ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+      REAL               MULTPL
+      PARAMETER          ( MULTPL = 4.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
+     $                   SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           SLAMCH, SLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = SLAMCH( '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 = SLAPY2( 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 = SLAPY2( 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 SLANV2
+*
+      END
diff --git a/SRC/slapll.f b/SRC/slapll.f
new file mode 100644
index 00000000..0f502aba
--- /dev/null
+++ b/SRC/slapll.f
@@ -0,0 +1,99 @@
+      SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, INCY, N
+      REAL               SSMIN
+*     ..
+*     .. Array Arguments ..
+      REAL               X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given two column vectors X and Y, let
+*
+*                       A = ( X Y ).
+*
+*  The subroutine first computes the QR factorization of A = Q*R,
+*  and then computes the SVD of the 2-by-2 upper triangular matrix R.
+*  The smaller singular value of R is returned in SSMIN, which is used
+*  as the measurement of the linear dependency of the vectors X and Y.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The length of the vectors X and Y.
+*
+*  X       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCX)
+*          On entry, X contains the N-vector X.
+*          On exit, X is overwritten.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive elements of X. INCX > 0.
+*
+*  Y       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCY)
+*          On entry, Y contains the N-vector Y.
+*          On exit, Y is overwritten.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive elements of Y. INCY > 0.
+*
+*  SSMIN   (output) REAL
+*          The smallest singular value of the N-by-2 matrix A = ( X Y ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               A11, A12, A22, C, SSMAX, TAU
+*     ..
+*     .. External Functions ..
+      REAL               SDOT
+      EXTERNAL           SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SLARFG, SLAS2
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         SSMIN = ZERO
+         RETURN
+      END IF
+*
+*     Compute the QR factorization of the N-by-2 matrix ( X Y )
+*
+      CALL SLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
+      A11 = X( 1 )
+      X( 1 ) = ONE
+*
+      C = -TAU*SDOT( N, X, INCX, Y, INCY )
+      CALL SAXPY( N, C, X, INCX, Y, INCY )
+*
+      CALL SLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
+*
+      A12 = Y( 1 )
+      A22 = Y( 1+INCY )
+*
+*     Compute the SVD of 2-by-2 Upper triangular matrix.
+*
+      CALL SLAS2( A11, A12, A22, SSMIN, SSMAX )
+*
+      RETURN
+*
+*     End of SLAPLL
+*
+      END
diff --git a/SRC/slapmt.f b/SRC/slapmt.f
new file mode 100644
index 00000000..1f24536b
--- /dev/null
+++ b/SRC/slapmt.f
@@ -0,0 +1,136 @@
+      SUBROUTINE SLAPMT( 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( * )
+      REAL               X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAPMT 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) REAL 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, J, IN
+      REAL               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 60 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
+*
+   60    CONTINUE
+*
+      ELSE
+*
+*        Backward permutation
+*
+         DO 110 I = 1, N
+*
+            IF( K( I ).GT.0 )
+     $         GO TO 100
+*
+            K( I ) = -K( I )
+            J = K( I )
+   80       CONTINUE
+            IF( J.EQ.I )
+     $         GO TO 100
+*
+            DO 90 II = 1, M
+               TEMP = X( II, I )
+               X( II, I ) = X( II, J )
+               X( II, J ) = TEMP
+   90       CONTINUE
+*
+            K( J ) = -K( J )
+            J = K( J )
+            GO TO 80
+*
+  100       CONTINUE
+
+  110    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLAPMT
+*
+      END
diff --git a/SRC/slapy2.f b/SRC/slapy2.f
new file mode 100644
index 00000000..0eac04fe
--- /dev/null
+++ b/SRC/slapy2.f
@@ -0,0 +1,53 @@
+      REAL             FUNCTION SLAPY2( X, Y )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      REAL               X, Y
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
+*  overflow.
+*
+*  Arguments
+*  =========
+*
+*  X       (input) REAL
+*  Y       (input) REAL
+*          X and Y specify the values x and y.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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
+         SLAPY2 = W
+      ELSE
+         SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
+      END IF
+      RETURN
+*
+*     End of SLAPY2
+*
+      END
diff --git a/SRC/slapy3.f b/SRC/slapy3.f
new file mode 100644
index 00000000..f5db3853
--- /dev/null
+++ b/SRC/slapy3.f
@@ -0,0 +1,56 @@
+      REAL             FUNCTION SLAPY3( X, Y, Z )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      REAL               X, Y, Z
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
+*  unnecessary overflow.
+*
+*  Arguments
+*  =========
+*
+*  X       (input) REAL
+*  Y       (input) REAL
+*  Z       (input) REAL
+*          X, Y and Z specify the values x, y and z.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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.
+         SLAPY3 =  XABS + YABS + ZABS
+      ELSE
+         SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
+     $            ( ZABS / W )**2 )
+      END IF
+      RETURN
+*
+*     End of SLAPY3
+*
+      END
diff --git a/SRC/slaqgb.f b/SRC/slaqgb.f
new file mode 100644
index 00000000..181d83ae
--- /dev/null
+++ b/SRC/slaqgb.f
@@ -0,0 +1,168 @@
+      SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, 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            KL, KU, LDAB, M, N
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQGB equilibrates a general M by N band matrix A with KL
+*  subdiagonals and KU superdiagonals using the row and scaling factors
+*  in the vectors R and C.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, the equilibrated matrix, in the same storage format
+*          as A.  See EQUED for the form of the equilibrated matrix.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDA >= KL+KU+1.
+*
+*  R       (input) REAL array, dimension (M)
+*          The row scale factors for A.
+*
+*  C       (input) REAL array, dimension (N)
+*          The column scale factors for A.
+*
+*  ROWCND  (input) REAL
+*          Ratio of the smallest R(i) to the largest R(i).
+*
+*  COLCND  (input) REAL
+*          Ratio of the smallest C(i) to the largest C(i).
+*
+*  AMAX    (input) REAL
+*          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 ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+     $     THEN
+*
+*        No row scaling
+*
+         IF( COLCND.GE.THRESH ) THEN
+*
+*           No column scaling
+*
+            EQUED = 'N'
+         ELSE
+*
+*           Column scaling
+*
+            DO 20 J = 1, N
+               CJ = C( J )
+               DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
+                  AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+            EQUED = 'C'
+         END IF
+      ELSE IF( COLCND.GE.THRESH ) THEN
+*
+*        Row scaling, no column scaling
+*
+         DO 40 J = 1, N
+            DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
+   30       CONTINUE
+   40    CONTINUE
+         EQUED = 'R'
+      ELSE
+*
+*        Row and column scaling
+*
+         DO 60 J = 1, N
+            CJ = C( J )
+            DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
+   50       CONTINUE
+   60    CONTINUE
+         EQUED = 'B'
+      END IF
+*
+      RETURN
+*
+*     End of SLAQGB
+*
+      END
diff --git a/SRC/slaqge.f b/SRC/slaqge.f
new file mode 100644
index 00000000..b3d87f26
--- /dev/null
+++ b/SRC/slaqge.f
@@ -0,0 +1,154 @@
+      SUBROUTINE SLAQGE( 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
+      REAL               AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQGE 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) REAL 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) REAL array, dimension (M)
+*          The row scale factors for A.
+*
+*  C       (input) REAL array, dimension (N)
+*          The column scale factors for A.
+*
+*  ROWCND  (input) REAL
+*          Ratio of the smallest R(i) to the largest R(i).
+*
+*  COLCND  (input) REAL
+*          Ratio of the smallest C(i) to the largest C(i).
+*
+*  AMAX    (input) REAL
+*          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 ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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 = SLAMCH( 'Safe minimum' ) / SLAMCH( '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 SLAQGE
+*
+      END
diff --git a/SRC/slaqp2.f b/SRC/slaqp2.f
new file mode 100644
index 00000000..ce47cb62
--- /dev/null
+++ b/SRC/slaqp2.f
@@ -0,0 +1,175 @@
+      SUBROUTINE SLAQP2( 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( * )
+      REAL               A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQP2 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) REAL 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) REAL array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) REAL array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) REAL array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
+      REAL               AII, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SLARFG, SSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SNRM2
+      EXTERNAL           ISAMAX, SLAMCH, SNRM2
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M-OFFSET, N )
+      TOL3Z = SQRT(SLAMCH('Epsilon'))
+*
+*     Compute factorization.
+*
+      DO 20 I = 1, MN
+*
+         OFFPI = OFFSET + I
+*
+*        Determine ith pivot column and swap if necessary.
+*
+         PVT = ( I-1 ) + ISAMAX( N-I+1, VN1( I ), 1 )
+*
+         IF( PVT.NE.I ) THEN
+            CALL SSWAP( 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 SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+     $                   TAU( I ) )
+         ELSE
+            CALL SLARFG( 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 SLARF( '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 ) = SNRM2( 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 SLAQP2
+*
+      END
diff --git a/SRC/slaqps.f b/SRC/slaqps.f
new file mode 100644
index 00000000..f71adf47
--- /dev/null
+++ b/SRC/slaqps.f
@@ -0,0 +1,259 @@
+      SUBROUTINE SLAQPS( 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( * )
+      REAL               A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+     $                   VN1( * ), VN2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQPS 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) REAL 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) REAL array, dimension (KB)
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) REAL array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) REAL array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  AUXV    (input/output) REAL array, dimension (NB)
+*          Auxiliar vector.
+*
+*  F       (input/output) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
+      REAL               AKK, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SGEMV, SLARFP, SSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, NINT, REAL, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SNRM2
+      EXTERNAL           ISAMAX, SLAMCH, SNRM2
+*     ..
+*     .. Executable Statements ..
+*
+      LASTRK = MIN( M, N+OFFSET )
+      LSTICC = 0
+      K = 0
+      TOL3Z = SQRT(SLAMCH('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 ) + ISAMAX( N-K+1, VN1( K ), 1 )
+         IF( PVT.NE.K ) THEN
+            CALL SSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
+            CALL SSWAP( 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 SGEMV( '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 SLARFP( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+         ELSE
+            CALL SLARFP( 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 SGEMV( '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 SGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ),
+     $                  LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 )
+*
+            CALL SGEMV( '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 SGEMV( '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 ) = REAL( 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 SGEMM( '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 ) = SNRM2( 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 SLAQPS
+*
+      END
diff --git a/SRC/slaqr0.f b/SRC/slaqr0.f
new file mode 100644
index 00000000..c79d2f28
--- /dev/null
+++ b/SRC/slaqr0.f
@@ -0,0 +1,640 @@
+      SUBROUTINE SLAQR0( 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 ..
+      REAL               H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     SLAQR0 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 SGEBAL, and then passed to SGEHRD when the
+*           matrix output by SGEBAL 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) REAL 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) REAL array, dimension (IHI)
+*     WI    (output) REAL 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) REAL 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) REAL 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 SLAQR0 does a workspace query.
+*           In this case, SLAQR0 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, SLAQR0 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
+*     .    SLAHQR 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 )
+      REAL               WILK1, WILK2
+      PARAMETER          ( WILK1 = 0.75e0, WILK2 = -0.4375e0 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               AA, BB, CC, CS, DD, SN, SS, SWAP
+      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 ..
+      REAL               ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACPY, SLAHQR, SLANV2, SLAQR3, SLAQR4, SLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, MAX, MIN, MOD, REAL
+*     ..
+*     .. 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 SLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL SLAHQR( 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, 'SLAQR0', 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, 'SLAQR0', 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 SLAQR3 ====
+*
+         CALL SLAQR3( 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(SLAQR5, SLAQR3) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = REAL( LWKOPT )
+            RETURN
+         END IF
+*
+*        ==== SLAHQR/SLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'SLAQR0', 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, 'SLAQR0', 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 SLAQR3( 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 SLAQR3
+*              .    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
+*              .    SLAQR3 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 SLANV2( 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 SLAQR4 or
+*                 .    SLAHQR 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 SLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     IF( NS.GT.NMIN ) THEN
+                        CALL SLAQR4( .false., .false., NS, 1, NS,
+     $                               H( KT, 1 ), LDH, WR( KS ),
+     $                               WI( KS ), 1, 1, ZDUM, 1, WORK,
+     $                               LWORK, INF )
+                     ELSE
+                        CALL SLAHQR( .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 SLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+     $                               WI( KBOT-1 ), WR( KBOT ),
+     $                               WI( KBOT ), CS, SN )
+                        KS = KBOT - 1
+                     END IF
+                  END IF
+*
+                  IF( KBOT-KS+1.GT.NS ) THEN
+*
+*                    ==== Sort the shifts (Helps a little)
+*                    .    Bubble sort keeps complex conjugate
+*                    .    pairs together. ====
+*
+                     SORTED = .false.
+                     DO 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 SLAQR5( 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 ) = REAL( LWKOPT )
+*
+*     ==== End of SLAQR0 ====
+*
+      END
diff --git a/SRC/slaqr1.f b/SRC/slaqr1.f
new file mode 100644
index 00000000..c7bdaa0f
--- /dev/null
+++ b/SRC/slaqr1.f
@@ -0,0 +1,97 @@
+      SUBROUTINE SLAQR1( 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 ..
+      REAL               SI1, SI2, SR1, SR2
+      INTEGER            LDH, N
+*     ..
+*     .. Array Arguments ..
+      REAL               H( LDH, * ), V( * )
+*     ..
+*
+*       Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 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) REAL 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) REAL
+*       SI1    The shifts in (*).
+*       SR2
+*       SI2
+*
+*       V      (output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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/slaqr2.f b/SRC/slaqr2.f
new file mode 100644
index 00000000..beeaee64
--- /dev/null
+++ b/SRC/slaqr2.f
@@ -0,0 +1,551 @@
+      SUBROUTINE SLAQR2( 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 ..
+      REAL               H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+     $                   V( LDV, * ), WORK( * ), WV( LDWV, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     This subroutine is identical to SLAQR3 except that it avoids
+*     recursion by calling SLAHQR instead of SLAQR4.
+*
+*
+*     ******************************************************************
+*     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) REAL 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) REAL 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) REAL array, dimension KBOT
+*     SI      (output) REAL array, dimension KBOT
+*          On output, the real and imaginary parts of approximate
+*          eigenvalues that may be used for shifts are stored in
+*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+*          The real and imaginary parts of converged eigenvalues
+*          are stored in SR(KBOT-ND+1) through SR(KBOT) and
+*          SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+*     V       (workspace) REAL 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) REAL 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) REAL array, dimension (LDWV,NW)
+*
+*     LDWV    (input) integer
+*          The leading dimension of W just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     WORK    (workspace) REAL array, dimension LWORK.
+*          On exit, WORK(1) is set to an estimate of the optimal value
+*          of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+*     LWORK   (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; SLAQR2
+*          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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR,
+     $                   SLANV2, SLARF, SLARFG, SLASET, SORGHR, STREXC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to SGEHRD ====
+*
+         CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to SORGHR ====
+*
+         CALL SORGHR( 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 ) = REAL( 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+     $             SI( KWTOP ), 1, JW, V, LDV, INFQR )
+*
+*     ==== STREXC 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.
+*              .    (STREXC can not fail in this case.) ====
+*
+               IFST = NS
+               CALL STREXC( '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, STREXC does the right thing with
+*              .    ILST in case of a rare exchange failure. ====
+*
+               IFST = NS
+               CALL STREXC( '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 STREXC( '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 SLANV2( 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 SCOPY( NS, V, LDV, WORK, 1 )
+            BETA = WORK( 1 )
+            CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL SGEHRD( 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 SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL SCOPY( 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  SORGHR 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 SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL SLACPY( '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 SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL SLACPY( '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 SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL SLACPY( '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 SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL SLACPY( '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 ) = REAL( LWKOPT )
+*
+*     ==== End of SLAQR2 ====
+*
+      END
diff --git a/SRC/slaqr3.f b/SRC/slaqr3.f
new file mode 100644
index 00000000..33b05d7c
--- /dev/null
+++ b/SRC/slaqr3.f
@@ -0,0 +1,561 @@
+      SUBROUTINE SLAQR3( 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 ..
+      REAL               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) REAL 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) REAL 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) REAL array, dimension KBOT
+*     SI      (output) REAL array, dimension KBOT
+*          On output, the real and imaginary parts of approximate
+*          eigenvalues that may be used for shifts are stored in
+*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+*          The real and imaginary parts of converged eigenvalues
+*          are stored in SR(KBOT-ND+1) through SR(KBOT) and
+*          SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+*     V       (workspace) REAL 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) REAL 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) REAL array, dimension (LDWV,NW)
+*
+*     LDWV    (input) integer
+*          The leading dimension of W just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     WORK    (workspace) REAL array, dimension LWORK.
+*          On exit, WORK(1) is set to an estimate of the optimal value
+*          of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+*     LWORK   (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; SLAQR3
+*          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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 ..
+      REAL               SLAMCH
+      INTEGER            ILAENV
+      EXTERNAL           SLAMCH, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR,
+     $                   SLANV2, SLAQR4, SLARF, SLARFG, SLASET, SORGHR,
+     $                   STREXC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to SGEHRD ====
+*
+         CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to SORGHR ====
+*
+         CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK2 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to SLAQR4 ====
+*
+         CALL SLAQR4( .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 ) = REAL( 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      NMIN = ILAENV( 12, 'SLAQR3', 'SV', JW, 1, JW, LWORK )
+      IF( JW.GT.NMIN ) THEN
+         CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+     $                SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
+      ELSE
+         CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+     $                SI( KWTOP ), 1, JW, V, LDV, INFQR )
+      END IF
+*
+*     ==== STREXC 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.
+*              .    (STREXC can not fail in this case.) ====
+*
+               IFST = NS
+               CALL STREXC( '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, STREXC does the right thing with
+*              .    ILST in case of a rare exchange failure. ====
+*
+               IFST = NS
+               CALL STREXC( '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 STREXC( '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 SLANV2( 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 SCOPY( NS, V, LDV, WORK, 1 )
+            BETA = WORK( 1 )
+            CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL SGEHRD( 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 SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL SCOPY( 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  SORGHR 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 SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL SLACPY( '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 SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL SLACPY( '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 SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL SLACPY( '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 SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL SLACPY( '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 ) = REAL( LWKOPT )
+*
+*     ==== End of SLAQR3 ====
+*
+      END
diff --git a/SRC/slaqr4.f b/SRC/slaqr4.f
new file mode 100644
index 00000000..306d1522
--- /dev/null
+++ b/SRC/slaqr4.f
@@ -0,0 +1,640 @@
+      SUBROUTINE SLAQR4( 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 ..
+      REAL               H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     This subroutine implements one level of recursion for SLAQR0.
+*     It is a complete implementation of the small bulge multi-shift
+*     QR algorithm.  It may be called by SLAQR0 and, for large enough
+*     deflation window size, it may be called by SLAQR3.  This
+*     subroutine is identical to SLAQR0 except that it calls SLAQR2
+*     instead of SLAQR3.
+*
+*     Purpose
+*     =======
+*
+*     SLAQR4 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 SGEBAL, and then passed to SGEHRD when the
+*           matrix output by SGEBAL 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) REAL 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) REAL array, dimension (IHI)
+*     WI    (output) REAL 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) REAL 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) REAL 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 SLAQR4 does a workspace query.
+*           In this case, SLAQR4 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, SLAQR4 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
+*     .    SLAHQR 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 )
+      REAL               WILK1, WILK2
+      PARAMETER          ( WILK1 = 0.75e0, WILK2 = -0.4375e0 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               AA, BB, CC, CS, DD, SN, SS, SWAP
+      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 ..
+      REAL               ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACPY, SLAHQR, SLANV2, SLAQR2, SLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, MAX, MIN, MOD, REAL
+*     ..
+*     .. 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 SLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL SLAHQR( 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, 'SLAQR4', 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, 'SLAQR4', 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 SLAQR2 ====
+*
+         CALL SLAQR2( 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(SLAQR5, SLAQR2) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = REAL( LWKOPT )
+            RETURN
+         END IF
+*
+*        ==== SLAHQR/SLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'SLAQR4', 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, 'SLAQR4', 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 SLAQR2( 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 SLAQR2
+*              .    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
+*              .    SLAQR2 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 SLANV2( 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 SLAHQR
+*                 .    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 SLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     CALL SLAHQR( .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 SLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+     $                               WI( KBOT-1 ), WR( KBOT ),
+     $                               WI( KBOT ), CS, SN )
+                        KS = KBOT - 1
+                     END IF
+                  END IF
+*
+                  IF( KBOT-KS+1.GT.NS ) THEN
+*
+*                    ==== Sort the shifts (Helps a little)
+*                    .    Bubble sort keeps complex conjugate
+*                    .    pairs together. ====
+*
+                     SORTED = .false.
+                     DO 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 SLAQR5( 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 ) = REAL( LWKOPT )
+*
+*     ==== End of SLAQR4 ====
+*
+      END
diff --git a/SRC/slaqr5.f b/SRC/slaqr5.f
new file mode 100644
index 00000000..8b144bb1
--- /dev/null
+++ b/SRC/slaqr5.f
@@ -0,0 +1,812 @@
+      SUBROUTINE SLAQR5( 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 ..
+      REAL               H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
+     $                   V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     This auxiliary subroutine called by SLAQR0 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: SLAQR5 does not accumulate reflections and does not
+*             use matrix-matrix multiply to update far-from-diagonal
+*             matrix entries.
+*        = 1: SLAQR5 accumulates reflections and uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries.
+*        = 2: SLAQR5 accumulates reflections, uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries,
+*             and takes advantage of 2-by-2 block structure during
+*             matrix multiplies.
+*
+*      N      (input) integer scalar
+*             N is the order of the Hessenberg matrix H upon which this
+*             subroutine operates.
+*
+*      KTOP   (input) integer scalar
+*      KBOT   (input) integer scalar
+*             These are the first and last rows and columns of an
+*             isolated diagonal block upon which the QR sweep is to be
+*             applied. It is assumed without a check that
+*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0
+*             and
+*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.
+*
+*      NSHFTS (input) integer scalar
+*             NSHFTS gives the number of simultaneous shifts.  NSHFTS
+*             must be positive and even.
+*
+*      SR     (input) REAL array of size (NSHFTS)
+*      SI     (input) REAL array of size (NSHFTS)
+*             SR contains the real parts and SI contains the imaginary
+*             parts of the NSHFTS shifts of origin that define the
+*             multi-shift QR sweep.
+*
+*      H      (input/output) REAL array of size (LDH,N)
+*             On input H contains a Hessenberg matrix.  On output a
+*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+*             to the isolated diagonal block in rows and columns KTOP
+*             through KBOT.
+*
+*      LDH    (input) integer scalar
+*             LDH is the leading dimension of H just as declared in the
+*             calling procedure.  LDH.GE.MAX(1,N).
+*
+*      ILOZ   (input) INTEGER
+*      IHIZ   (input) INTEGER
+*             Specify the rows of Z to which transformations must be
+*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+*      Z      (input/output) REAL array of size (LDZ,IHI)
+*             If WANTZ = .TRUE., then the QR Sweep orthogonal
+*             similarity transformation is accumulated into
+*             Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*             If WANTZ = .FALSE., then Z is unreferenced.
+*
+*      LDZ    (input) integer scalar
+*             LDA is the leading dimension of Z just as declared in
+*             the calling procedure. LDZ.GE.N.
+*
+*      V      (workspace) REAL array of size (LDV,NSHFTS/2)
+*
+*      LDV    (input) integer scalar
+*             LDV is the leading dimension of V as declared in the
+*             calling procedure.  LDV.GE.3.
+*
+*      U      (workspace) REAL array of size
+*             (LDU,3*NSHFTS-3)
+*
+*      LDU    (input) integer scalar
+*             LDU is the leading dimension of U just as declared in the
+*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.
+*
+*      NH     (input) integer scalar
+*             NH is the number of columns in array WH available for
+*             workspace. NH.GE.1.
+*
+*      WH     (workspace) REAL array of size (LDWH,NH)
+*
+*      LDWH   (input) integer scalar
+*             Leading dimension of WH just as declared in the
+*             calling procedure.  LDWH.GE.3*NSHFTS-3.
+*
+*      NV     (input) integer scalar
+*             NV is the number of rows in WV agailable for workspace.
+*             NV.GE.1.
+*
+*      WV     (workspace) REAL array of size
+*             (LDWV,3*NSHFTS-3)
+*
+*      LDWV   (input) integer scalar
+*             LDWV is the leading dimension of WV as declared in the
+*             in the calling subroutine.  LDWV.GE.NV.
+*
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ============================================================
+*     Reference:
+*
+*     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*     Algorithm Part I: Maintaining Well Focused Shifts, and
+*     Level 3 Performance, SIAM Journal of Matrix Analysis,
+*     volume 23, pages 929--947, 2002.
+*
+*     ============================================================
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0e0, ONE = 1.0e0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+     $                   SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+     $                   ULP
+      INTEGER            I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+     $                   JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
+     $                   M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
+     $                   NS, NU
+      LOGICAL            ACCUM, BLK22, BMP22
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+*
+      INTRINSIC          ABS, MAX, MIN, MOD, REAL
+*     ..
+*     .. Local Arrays ..
+      REAL               VT( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLABAD, SLACPY, SLAQR1, SLARFG, SLASET,
+     $                   STRMM
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== If there are no shifts, then there is nothing to do. ====
+*
+      IF( NSHFTS.LT.2 )
+     $   RETURN
+*
+*     ==== If the active block is empty or 1-by-1, then there
+*     .    is nothing to do. ====
+*
+      IF( KTOP.GE.KBOT )
+     $   RETURN
+*
+*     ==== 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 = SLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, SAFMAX )
+      ULP = SLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( REAL( 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 SLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
+*
+*        ==== Near-the-diagonal bulge chase.  The following loop
+*        .    performs the near-the-diagonal part of a small bulge
+*        .    multi-shift QR sweep.  Each 6*NBMPS-2 column diagonal
+*        .    chunk extends from column INCOL to column NDCOL
+*        .    (including both column INCOL and column NDCOL). The
+*        .    following loop chases a 3*NBMPS column long chain of
+*        .    NBMPS bulges 3*NBMPS-2 columns to the right.  (INCOL
+*        .    may be less than KTOP and and NDCOL may be greater than
+*        .    KBOT indicating phantom columns from which to chase
+*        .    bulges before they are actually introduced or to which
+*        .    to chase bulges beyond column KBOT.)  ====
+*
+         DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
+*
+*           ==== Bulges number MTOP to MBOT are active double implicit
+*           .    shift bulges.  There may or may not also be small
+*           .    2-by-2 bulge, if there is room.  The inactive bulges
+*           .    (if any) must wait until the active bulges have moved
+*           .    down the diagonal to make room.  The phantom matrix
+*           .    paradigm described above helps keep track.  ====
+*
+            MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
+            MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
+            M22 = MBOT + 1
+            BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
+     $              ( KBOT-2 )
+*
+*           ==== Generate reflections to chase the chain right
+*           .    one column.  (The minimum value of K is KTOP-1.) ====
+*
+            DO 20 M = MTOP, MBOT
+               K = KRCOL + 3*( M-1 )
+               IF( K.EQ.KTOP-1 ) THEN
+                  CALL SLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ),
+     $                         SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+     $                         V( 1, M ) )
+                  ALPHA = V( 1, M )
+                  CALL SLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M ) = H( K+2, K )
+                  V( 3, M ) = H( K+3, K )
+                  CALL SLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
+*
+*                 ==== A Bulge may collapse because of vigilant
+*                 .    deflation or destructive underflow.  (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 SLAQR1( 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 SLARFG( 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 SLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ),
+     $                         SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ),
+     $                         V( 1, M22 ) )
+                  BETA = V( 1, M22 )
+                  CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M22 ) = H( K+2, K )
+                  CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+                  H( K+1, K ) = BETA
+                  H( K+2, K ) = ZERO
+               END IF
+            ELSE
+*
+*              ==== Initialize V(1,M22) here to avoid possible undefined
+*              .    variable problems later. ====
+*
+               V( 1, M22 ) = ZERO
+            END IF
+*
+*           ==== Multiply H by reflections from the left ====
+*
+            IF( ACCUM ) THEN
+               JBOT = MIN( 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 SGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+     $                        LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+     $                        LDWH )
+                  CALL SLACPY( 'ALL', NU, JLEN, WH, LDWH,
+     $                         H( INCOL+K1, JCOL ), LDH )
+  160          CONTINUE
+*
+*              ==== Vertical multiply ====
+*
+               DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
+                  JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
+                  CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                        H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+     $                        LDU, ZERO, WV, LDWV )
+                  CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV,
+     $                         H( JROW, INCOL+K1 ), LDH )
+  170          CONTINUE
+*
+*              ==== Z multiply (also vertical) ====
+*
+               IF( WANTZ ) THEN
+                  DO 180 JROW = ILOZ, IHIZ, NV
+                     JLEN = MIN( NV, IHIZ-JROW+1 )
+                     CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                           Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+     $                           LDU, ZERO, WV, LDWV )
+                     CALL SLACPY( '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 SLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+     $                         LDH, WH( KZS+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL SLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+                  CALL STRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+     $                        LDWH )
+*
+*                 ==== Multiply top of H by U11' ====
+*
+                  CALL SGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+     $                        H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+*                 ==== Copy top of H bottom of WH ====
+*
+                  CALL SLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+     $                         WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL STRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+     $                        U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL SGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
+     $                        U( J2+1, I2+1 ), LDU,
+     $                        H( INCOL+1+J2, JCOL ), LDH, ONE,
+     $                        WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Copy it back ====
+*
+                  CALL SLACPY( '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 SLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+     $                         LDH, WV( 1, 1+KZS ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+                  CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                        LDWV )
+*
+*                 ==== Multiply by U11 ====
+*
+                  CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+     $                        H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
+     $                        LDWV )
+*
+*                 ==== Copy left of H to right of scratch ====
+*
+                  CALL SLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+     $                         WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                        U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+     $                        H( JROW, INCOL+1+J2 ), LDH,
+     $                        U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
+     $                        LDWV )
+*
+*                 ==== Copy it back ====
+*
+                  CALL SLACPY( '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 SLACPY( 'ALL', JLEN, KNZ,
+     $                            Z( JROW, INCOL+1+J2 ), LDZ,
+     $                            WV( 1, 1+KZS ), LDWV )
+*
+*                    ==== Multiply by U12 ====
+*
+                     CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+     $                            LDWV )
+                     CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                           U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U11 ====
+*
+                     CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+     $                           Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
+     $                           WV, LDWV )
+*
+*                    ==== Copy left of Z to right of scratch ====
+*
+                     CALL SLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+     $                            LDZ, WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Multiply by U21 ====
+*
+                     CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                           U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U22 ====
+*
+                     CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+     $                           Z( JROW, INCOL+1+J2 ), LDZ,
+     $                           U( J2+1, I2+1 ), LDU, ONE,
+     $                           WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Copy the result back to Z ====
+*
+                     CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+     $                            Z( JROW, INCOL+1 ), LDZ )
+  210             CONTINUE
+               END IF
+            END IF
+         END IF
+  220 CONTINUE
+*
+*     ==== End of SLAQR5 ====
+*
+      END
diff --git a/SRC/slaqsb.f b/SRC/slaqsb.f
new file mode 100644
index 00000000..807af554
--- /dev/null
+++ b/SRC/slaqsb.f
@@ -0,0 +1,148 @@
+      SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            KD, LDAB, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQSB equilibrates a symmetric band matrix A using the scaling
+*  factors in the vector S.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored in band format.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = MAX( 1, J-KD ), J
+                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, MIN( N, J+KD )
+                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of SLAQSB
+*
+      END
diff --git a/SRC/slaqsp.f b/SRC/slaqsp.f
new file mode 100644
index 00000000..40ed3965
--- /dev/null
+++ b/SRC/slaqsp.f
@@ -0,0 +1,140 @@
+      SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQSP equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
+*          the same storage format as A.
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JC
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            JC = 1
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+   10          CONTINUE
+               JC = JC + J
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            JC = 1
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+   30          CONTINUE
+               JC = JC + N - J + 1
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of SLAQSP
+*
+      END
diff --git a/SRC/slaqsy.f b/SRC/slaqsy.f
new file mode 100644
index 00000000..864cbedf
--- /dev/null
+++ b/SRC/slaqsy.f
@@ -0,0 +1,141 @@
+      SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            LDA, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQSY equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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) REAL array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if EQUED = 'Y', the equilibrated matrix:
+*          diag(S) * A * diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  S       (input) REAL array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) REAL
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) REAL
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, THRESH
+      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      REAL               CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of SLAQSY
+*
+      END
diff --git a/SRC/slaqtr.f b/SRC/slaqtr.f
new file mode 100644
index 00000000..abd1d0af
--- /dev/null
+++ b/SRC/slaqtr.f
@@ -0,0 +1,665 @@
+      SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            LREAL, LTRAN
+      INTEGER            INFO, LDT, N
+      REAL               SCALE, W
+*     ..
+*     .. Array Arguments ..
+      REAL               B( * ), T( LDT, * ), WORK( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAQTR solves the real quasi-triangular system
+*
+*               op(T)*p = scale*c,               if LREAL = .TRUE.
+*
+*  or the complex quasi-triangular systems
+*
+*             op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.
+*
+*  in real arithmetic, where T is upper quasi-triangular.
+*  If LREAL = .FALSE., then the first diagonal block of T must be
+*  1 by 1, B is the specially structured matrix
+*
+*                 B = [ b(1) b(2) ... b(n) ]
+*                     [       w            ]
+*                     [           w        ]
+*                     [              .     ]
+*                     [                 w  ]
+*
+*  op(A) = A or A', A' denotes the conjugate transpose of
+*  matrix A.
+*
+*  On input, X = [ c ].  On output, X = [ p ].
+*                [ d ]                  [ q ]
+*
+*  This subroutine is designed for the condition number estimation
+*  in routine STRSNA.
+*
+*  Arguments
+*  =========
+*
+*  LTRAN   (input) LOGICAL
+*          On entry, LTRAN specifies the option of conjugate transpose:
+*             = .FALSE.,    op(T+i*B) = T+i*B,
+*             = .TRUE.,     op(T+i*B) = (T+i*B)'.
+*
+*  LREAL   (input) LOGICAL
+*          On entry, LREAL specifies the input matrix structure:
+*             = .FALSE.,    the input is complex
+*             = .TRUE.,     the input is real
+*
+*  N       (input) INTEGER
+*          On entry, N specifies the order of T+i*B. N >= 0.
+*
+*  T       (input) REAL array, dimension (LDT,N)
+*          On entry, T contains a matrix in Schur canonical form.
+*          If LREAL = .FALSE., then the first diagonal block of T must
+*          be 1 by 1.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the matrix T. LDT >= max(1,N).
+*
+*  B       (input) REAL array, dimension (N)
+*          On entry, B contains the elements to form the matrix
+*          B as described above.
+*          If LREAL = .TRUE., B is not referenced.
+*
+*  W       (input) REAL
+*          On entry, W is the diagonal element of the matrix B.
+*          If LREAL = .TRUE., W is not referenced.
+*
+*  SCALE   (output) REAL
+*          On exit, SCALE is the scale factor.
+*
+*  X       (input/output) REAL array, dimension (2*N)
+*          On entry, X contains the right hand side of the system.
+*          On exit, X is overwritten by the solution.
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO is set to
+*             0: successful exit.
+*               1: the some diagonal 1 by 1 block has been perturbed by
+*                  a small number SMIN to keep nonsingularity.
+*               2: the some diagonal 2 by 2 block has been perturbed by
+*                  a small number in SLALN2 to keep nonsingularity.
+*          NOTE: In the interests of speed, this routine does not
+*                check the inputs for errors.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            I, IERR, J, J1, J2, JNEXT, K, N1, N2
+      REAL               BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
+     $                   SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
+*     ..
+*     .. Local Arrays ..
+      REAL               D( 2, 2 ), V( 2, 2 )
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SASUM, SDOT, SLAMCH, SLANGE
+      EXTERNAL           ISAMAX, SASUM, SDOT, SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SLADIV, SLALN2, SSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Do not test the input parameters for errors
+*
+      NOTRAN = .NOT.LTRAN
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+      XNORM = SLANGE( 'M', N, N, T, LDT, D )
+      IF( .NOT.LREAL )
+     $   XNORM = MAX( XNORM, ABS( W ), SLANGE( 'M', N, 1, B, N, D ) )
+      SMIN = MAX( SMLNUM, EPS*XNORM )
+*
+*     Compute 1-norm of each column of strictly upper triangular
+*     part of T to control overflow in triangular solver.
+*
+      WORK( 1 ) = ZERO
+      DO 10 J = 2, N
+         WORK( J ) = SASUM( J-1, T( 1, J ), 1 )
+   10 CONTINUE
+*
+      IF( .NOT.LREAL ) THEN
+         DO 20 I = 2, N
+            WORK( I ) = WORK( I ) + ABS( B( I ) )
+   20    CONTINUE
+      END IF
+*
+      N2 = 2*N
+      N1 = N
+      IF( .NOT.LREAL )
+     $   N1 = N2
+      K = ISAMAX( N1, X, 1 )
+      XMAX = ABS( X( K ) )
+      SCALE = ONE
+*
+      IF( XMAX.GT.BIGNUM ) THEN
+         SCALE = BIGNUM / XMAX
+         CALL SSCAL( N1, SCALE, X, 1 )
+         XMAX = BIGNUM
+      END IF
+*
+      IF( LREAL ) THEN
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve T*p = scale*c
+*
+            JNEXT = N
+            DO 30 J = N, 1, -1
+               IF( J.GT.JNEXT )
+     $            GO TO 30
+               J1 = J
+               J2 = J
+               JNEXT = J - 1
+               IF( J.GT.1 ) THEN
+                  IF( T( J, J-1 ).NE.ZERO ) THEN
+                     J1 = J - 1
+                     JNEXT = J - 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 Meet 1 by 1 diagonal block
+*
+*                 Scale to avoid overflow when computing
+*                     x(j) = b(j)/T(j,j)
+*
+                  XJ = ABS( X( J1 ) )
+                  TJJ = ABS( T( J1, J1 ) )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMIN ) THEN
+                     TMP = SMIN
+                     TJJ = SMIN
+                     INFO = 1
+                  END IF
+*
+                  IF( XJ.EQ.ZERO )
+     $               GO TO 30
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL SSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J1 ) = X( J1 ) / TMP
+                  XJ = ABS( X( J1 ) )
+*
+*                 Scale x if necessary to avoid overflow when adding a
+*                 multiple of column j1 of T.
+*
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+                        CALL SSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+                  IF( J1.GT.1 ) THEN
+                     CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     K = ISAMAX( J1-1, X, 1 )
+                     XMAX = ABS( X( K ) )
+                  END IF
+*
+               ELSE
+*
+*                 Meet 2 by 2 diagonal block
+*
+*                 Call 2 by 2 linear system solve, to take
+*                 care of possible overflow by scaling factor.
+*
+                  D( 1, 1 ) = X( J1 )
+                  D( 2, 1 ) = X( J2 )
+                  CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL SSCAL( N, SCALOC, X, 1 )
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+*
+*                 Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
+*                 to avoid overflow in updating right-hand side.
+*
+                  XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+     $                   ( BIGNUM-XMAX )*REC ) THEN
+                        CALL SSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+*
+*                 Update right-hand side
+*
+                  IF( J1.GT.1 ) THEN
+                     CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     CALL SAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+                     K = ISAMAX( J1-1, X, 1 )
+                     XMAX = ABS( X( K ) )
+                  END IF
+*
+               END IF
+*
+   30       CONTINUE
+*
+         ELSE
+*
+*           Solve T'*p = scale*c
+*
+            JNEXT = 1
+            DO 40 J = 1, N
+               IF( J.LT.JNEXT )
+     $            GO TO 40
+               J1 = J
+               J2 = J
+               JNEXT = J + 1
+               IF( J.LT.N ) THEN
+                  IF( T( J+1, J ).NE.ZERO ) THEN
+                     J2 = J + 1
+                     JNEXT = J + 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 1 by 1 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side element by inner product.
+*
+                  XJ = ABS( X( J1 ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+                        CALL SSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  X( J1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+*
+                  XJ = ABS( X( J1 ) )
+                  TJJ = ABS( T( J1, J1 ) )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMIN ) THEN
+                     TMP = SMIN
+                     TJJ = SMIN
+                     INFO = 1
+                  END IF
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL SSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J1 ) = X( J1 ) / TMP
+                  XMAX = MAX( XMAX, ABS( X( J1 ) ) )
+*
+               ELSE
+*
+*                 2 by 2 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side elements by inner product.
+*
+                  XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
+     $                   REC ) THEN
+                        CALL SSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  D( 1, 1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X,
+     $                        1 )
+                  D( 2, 1 ) = X( J2 ) - SDOT( J1-1, T( 1, J2 ), 1, X,
+     $                        1 )
+*
+                  CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL SSCAL( N, SCALOC, X, 1 )
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+                  XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
+*
+               END IF
+   40       CONTINUE
+         END IF
+*
+      ELSE
+*
+         SMINW = MAX( EPS*ABS( W ), SMIN )
+         IF( NOTRAN ) THEN
+*
+*           Solve (T + iB)*(p+iq) = c+id
+*
+            JNEXT = N
+            DO 70 J = N, 1, -1
+               IF( J.GT.JNEXT )
+     $            GO TO 70
+               J1 = J
+               J2 = J
+               JNEXT = J - 1
+               IF( J.GT.1 ) THEN
+                  IF( T( J, J-1 ).NE.ZERO ) THEN
+                     J1 = J - 1
+                     JNEXT = J - 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 1 by 1 diagonal block
+*
+*                 Scale if necessary to avoid overflow in division
+*
+                  Z = W
+                  IF( J1.EQ.1 )
+     $               Z = B( 1 )
+                  XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+                  TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMINW ) THEN
+                     TMP = SMINW
+                     TJJ = SMINW
+                     INFO = 1
+                  END IF
+*
+                  IF( XJ.EQ.ZERO )
+     $               GO TO 70
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL SSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  CALL SLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
+                  X( J1 ) = SR
+                  X( N+J1 ) = SI
+                  XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+*
+*                 Scale x if necessary to avoid overflow when adding a
+*                 multiple of column j1 of T.
+*
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+                        CALL SSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+*
+                  IF( J1.GT.1 ) THEN
+                     CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     CALL SAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+     $                           X( N+1 ), 1 )
+*
+                     X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
+                     X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
+*
+                     XMAX = ZERO
+                     DO 50 K = 1, J1 - 1
+                        XMAX = MAX( XMAX, ABS( X( K ) )+
+     $                         ABS( X( K+N ) ) )
+   50                CONTINUE
+                  END IF
+*
+               ELSE
+*
+*                 Meet 2 by 2 diagonal block
+*
+                  D( 1, 1 ) = X( J1 )
+                  D( 2, 1 ) = X( J2 )
+                  D( 1, 2 ) = X( N+J1 )
+                  D( 2, 2 ) = X( N+J2 )
+                  CALL SLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL SSCAL( 2*N, SCALOC, X, 1 )
+                     SCALE = SCALOC*SCALE
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+                  X( N+J1 ) = V( 1, 2 )
+                  X( N+J2 ) = V( 2, 2 )
+*
+*                 Scale X(J1), .... to avoid overflow in
+*                 updating right hand side.
+*
+                  XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
+     $                 ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
+                  IF( XJ.GT.ONE ) THEN
+                     REC = ONE / XJ
+                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+     $                   ( BIGNUM-XMAX )*REC ) THEN
+                        CALL SSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                     END IF
+                  END IF
+*
+*                 Update the right-hand side.
+*
+                  IF( J1.GT.1 ) THEN
+                     CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+                     CALL SAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+*
+                     CALL SAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+     $                           X( N+1 ), 1 )
+                     CALL SAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
+     $                           X( N+1 ), 1 )
+*
+                     X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
+     $                        B( J2 )*X( N+J2 )
+                     X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
+     $                          B( J2 )*X( J2 )
+*
+                     XMAX = ZERO
+                     DO 60 K = 1, J1 - 1
+                        XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
+     $                         XMAX )
+   60                CONTINUE
+                  END IF
+*
+               END IF
+   70       CONTINUE
+*
+         ELSE
+*
+*           Solve (T + iB)'*(p+iq) = c+id
+*
+            JNEXT = 1
+            DO 80 J = 1, N
+               IF( J.LT.JNEXT )
+     $            GO TO 80
+               J1 = J
+               J2 = J
+               JNEXT = J + 1
+               IF( J.LT.N ) THEN
+                  IF( T( J+1, J ).NE.ZERO ) THEN
+                     J2 = J + 1
+                     JNEXT = J + 2
+                  END IF
+               END IF
+*
+               IF( J1.EQ.J2 ) THEN
+*
+*                 1 by 1 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side element by inner product.
+*
+                  XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+                        CALL SSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  X( J1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+                  X( N+J1 ) = X( N+J1 ) - SDOT( J1-1, T( 1, J1 ), 1,
+     $                        X( N+1 ), 1 )
+                  IF( J1.GT.1 ) THEN
+                     X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
+                     X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
+                  END IF
+                  XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+*
+                  Z = W
+                  IF( J1.EQ.1 )
+     $               Z = B( 1 )
+*
+*                 Scale if necessary to avoid overflow in
+*                 complex division
+*
+                  TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+                  TMP = T( J1, J1 )
+                  IF( TJJ.LT.SMINW ) THEN
+                     TMP = SMINW
+                     TJJ = SMINW
+                     INFO = 1
+                  END IF
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.BIGNUM*TJJ ) THEN
+                        REC = ONE / XJ
+                        CALL SSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  CALL SLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
+                  X( J1 ) = SR
+                  X( J1+N ) = SI
+                  XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
+*
+               ELSE
+*
+*                 2 by 2 diagonal block
+*
+*                 Scale if necessary to avoid overflow in forming the
+*                 right-hand side element by inner product.
+*
+                  XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+     $                 ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
+                  IF( XMAX.GT.ONE ) THEN
+                     REC = ONE / XMAX
+                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+     $                   ( BIGNUM-XJ ) / XMAX ) THEN
+                        CALL SSCAL( N2, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+*
+                  D( 1, 1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X,
+     $                        1 )
+                  D( 2, 1 ) = X( J2 ) - SDOT( J1-1, T( 1, J2 ), 1, X,
+     $                        1 )
+                  D( 1, 2 ) = X( N+J1 ) - SDOT( J1-1, T( 1, J1 ), 1,
+     $                        X( N+1 ), 1 )
+                  D( 2, 2 ) = X( N+J2 ) - SDOT( J1-1, T( 1, J2 ), 1,
+     $                        X( N+1 ), 1 )
+                  D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
+                  D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
+                  D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
+                  D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
+*
+                  CALL SLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
+     $                         LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
+     $                         SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 2
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     CALL SSCAL( N2, SCALOC, X, 1 )
+                     SCALE = SCALOC*SCALE
+                  END IF
+                  X( J1 ) = V( 1, 1 )
+                  X( J2 ) = V( 2, 1 )
+                  X( N+J1 ) = V( 1, 2 )
+                  X( N+J2 ) = V( 2, 2 )
+                  XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+     $                   ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
+*
+               END IF
+*
+   80       CONTINUE
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLAQTR
+*
+      END
diff --git a/SRC/slar1v.f b/SRC/slar1v.f
new file mode 100644
index 00000000..85364a96
--- /dev/null
+++ b/SRC/slar1v.f
@@ -0,0 +1,369 @@
+      SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
+     $           PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+     $           R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTNC
+      INTEGER   B1, BN, N, NEGCNT, R
+      REAL               GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+     $                   RQCORR, ZTZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * )
+      REAL               D( * ), L( * ), LD( * ), LLD( * ),
+     $                  WORK( * )
+      REAL             Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAR1V computes the (scaled) r-th column of the inverse of
+*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+*  L D L^T - sigma I. When sigma is close to an eigenvalue, the
+*  computed vector is an accurate eigenvector. Usually, r corresponds
+*  to the index where the eigenvector is largest in magnitude.
+*  The following steps accomplish this computation :
+*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
+*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+*  (c) Computation of the diagonal elements of the inverse of
+*      L D L^T - sigma I by combining the above transforms, and choosing
+*      r as the index where the diagonal of the inverse is (one of the)
+*      largest in magnitude.
+*  (d) Computation of the (scaled) r-th column of the inverse using the
+*      twisted factorization obtained by combining the top part of the
+*      the stationary and the bottom part of the progressive transform.
+*
+*  Arguments
+*  =========
+*
+*  N        (input) INTEGER
+*           The order of the matrix L D L^T.
+*
+*  B1       (input) INTEGER
+*           First index of the submatrix of L D L^T.
+*
+*  BN       (input) INTEGER
+*           Last index of the submatrix of L D L^T.
+*
+*  LAMBDA    (input) REAL            
+*           The shift. In order to compute an accurate eigenvector,
+*           LAMBDA should be a good approximation to an eigenvalue
+*           of L D L^T.
+*
+*  L        (input) REAL             array, dimension (N-1)
+*           The (n-1) subdiagonal elements of the unit bidiagonal matrix
+*           L, in elements 1 to N-1.
+*
+*  D        (input) REAL             array, dimension (N)
+*           The n diagonal elements of the diagonal matrix D.
+*
+*  LD       (input) REAL             array, dimension (N-1)
+*           The n-1 elements L(i)*D(i).
+*
+*  LLD      (input) REAL             array, dimension (N-1)
+*           The n-1 elements L(i)*L(i)*D(i).
+*
+*  PIVMIN   (input) REAL            
+*           The minimum pivot in the Sturm sequence.
+*
+*  GAPTOL   (input) REAL            
+*           Tolerance that indicates when eigenvector entries are negligible
+*           w.r.t. their contribution to the residual.
+*
+*  Z        (input/output) REAL             array, dimension (N)
+*           On input, all entries of Z must be set to 0.
+*           On output, Z contains the (scaled) r-th column of the
+*           inverse. The scaling is such that Z(R) equals 1.
+*
+*  WANTNC   (input) LOGICAL
+*           Specifies whether NEGCNT has to be computed.
+*
+*  NEGCNT   (output) INTEGER
+*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+*  ZTZ      (output) REAL            
+*           The square of the 2-norm of Z.
+*
+*  MINGMA   (output) REAL            
+*           The reciprocal of the largest (in magnitude) diagonal
+*           element of the inverse of L D L^T - sigma I.
+*
+*  R        (input/output) INTEGER
+*           The twist index for the twisted factorization used to
+*           compute Z.
+*           On input, 0 <= R <= N. If R is input as 0, R is set to
+*           the index where (L D L^T - sigma I)^{-1} is largest
+*           in magnitude. If 1 <= R <= N, R is unchanged.
+*           On output, R contains the twist index used to compute Z.
+*           Ideally, R designates the position of the maximum entry in the
+*           eigenvector.
+*
+*  ISUPPZ   (output) INTEGER array, dimension (2)
+*           The support of the vector in Z, i.e., the vector Z is
+*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+*  NRMINV   (output) REAL            
+*           NRMINV = 1/SQRT( ZTZ )
+*
+*  RESID    (output) REAL            
+*           The residual of the FP vector.
+*           RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+*  RQCORR   (output) REAL            
+*           The Rayleigh Quotient correction to LAMBDA.
+*           RQCORR = MINGMA*TMP
+*
+*  WORK     (workspace) REAL             array, dimension (4*N)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SAWNAN1, SAWNAN2
+      INTEGER            I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
+     $                   R2
+      REAL               DMINUS, DPLUS, EPS, S, TMP
+*     ..
+*     .. External Functions ..
+      LOGICAL SISNAN
+      REAL               SLAMCH
+      EXTERNAL           SISNAN, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = SLAMCH( 'Precision' )
+
+
+      IF( R.EQ.0 ) THEN
+         R1 = B1
+         R2 = BN
+      ELSE
+         R1 = R
+         R2 = R
+      END IF
+
+*     Storage for LPLUS
+      INDLPL = 0
+*     Storage for UMINUS
+      INDUMN = N
+      INDS = 2*N + 1
+      INDP = 3*N + 1
+
+      IF( B1.EQ.1 ) THEN
+         WORK( INDS ) = ZERO
+      ELSE
+         WORK( INDS+B1-1 ) = LLD( B1-1 )
+      END IF
+
+*
+*     Compute the stationary transform (using the differential form)
+*     until the index R2.
+*
+      SAWNAN1 = .FALSE.
+      NEG1 = 0
+      S = WORK( INDS+B1-1 ) - LAMBDA
+      DO 50 I = B1, R1 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 50   CONTINUE
+      SAWNAN1 = SISNAN( S )
+      IF( SAWNAN1 ) GOTO 60
+      DO 51 I = R1, R2 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 51   CONTINUE
+      SAWNAN1 = SISNAN( S )
+*
+ 60   CONTINUE
+      IF( SAWNAN1 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG1 = 0
+         S = WORK( INDS+B1-1 ) - LAMBDA
+         DO 70 I = B1, R1 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 70      CONTINUE
+         DO 71 I = R1, R2 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 71      CONTINUE
+      END IF
+*
+*     Compute the progressive transform (using the differential form)
+*     until the index R1
+*
+      SAWNAN2 = .FALSE.
+      NEG2 = 0
+      WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
+      DO 80 I = BN - 1, R1, -1
+         DMINUS = LLD( I ) + WORK( INDP+I )
+         TMP = D( I ) / DMINUS
+         IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+         WORK( INDUMN+I ) = L( I )*TMP
+         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ 80   CONTINUE
+      TMP = WORK( INDP+R1-1 )
+      SAWNAN2 = SISNAN( TMP )
+
+      IF( SAWNAN2 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG2 = 0
+         DO 100 I = BN-1, R1, -1
+            DMINUS = LLD( I ) + WORK( INDP+I )
+            IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
+            TMP = D( I ) / DMINUS
+            IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+            WORK( INDUMN+I ) = L( I )*TMP
+            WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+            IF( TMP.EQ.ZERO )
+     $          WORK( INDP+I-1 ) = D( I ) - LAMBDA
+ 100     CONTINUE
+      END IF
+*
+*     Find the index (from R1 to R2) of the largest (in magnitude)
+*     diagonal element of the inverse
+*
+      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
+      IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
+      IF( WANTNC ) THEN
+         NEGCNT = NEG1 + NEG2
+      ELSE
+         NEGCNT = -1
+      ENDIF
+      IF( ABS(MINGMA).EQ.ZERO )
+     $   MINGMA = EPS*WORK( INDS+R1-1 )
+      R = R1
+      DO 110 I = R1, R2 - 1
+         TMP = WORK( INDS+I ) + WORK( INDP+I )
+         IF( TMP.EQ.ZERO )
+     $      TMP = EPS*WORK( INDS+I )
+         IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
+            MINGMA = TMP
+            R = I + 1
+         END IF
+ 110  CONTINUE
+*
+*     Compute the FP vector: solve N^T v = e_r
+*
+      ISUPPZ( 1 ) = B1
+      ISUPPZ( 2 ) = BN
+      Z( R ) = ONE
+      ZTZ = ONE
+*
+*     Compute the FP vector upwards from R
+*
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 210 I = R-1, B1, -1
+            Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GOTO 220
+            ENDIF
+            ZTZ = ZTZ + Z( I )*Z( I )
+ 210     CONTINUE
+ 220     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 230 I = R - 1, B1, -1
+            IF( Z( I+1 ).EQ.ZERO ) THEN
+               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
+            ELSE
+               Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GO TO 240
+            END IF
+            ZTZ = ZTZ + Z( I )*Z( I )
+ 230     CONTINUE
+ 240     CONTINUE
+      ENDIF
+
+*     Compute the FP vector downwards from R in blocks of size BLKSIZ
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 250 I = R, BN-1
+            Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $         THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 260
+            END IF
+            ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 250     CONTINUE
+ 260     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 270 I = R, BN - 1
+            IF( Z( I ).EQ.ZERO ) THEN
+               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
+            ELSE
+               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 280
+            END IF
+            ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 270     CONTINUE
+ 280     CONTINUE
+      END IF
+*
+*     Compute quantities for convergence test
+*
+      TMP = ONE / ZTZ
+      NRMINV = SQRT( TMP )
+      RESID = ABS( MINGMA )*NRMINV
+      RQCORR = MINGMA*TMP
+*
+*
+      RETURN
+*
+*     End of SLAR1V
+*
+      END
diff --git a/SRC/slar2v.f b/SRC/slar2v.f
new file mode 100644
index 00000000..4dcceb32
--- /dev/null
+++ b/SRC/slar2v.f
@@ -0,0 +1,86 @@
+      SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, N
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), S( * ), X( * ), Y( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAR2V applies a vector of real plane rotations from both sides to
+*  a sequence of 2-by-2 real symmetric matrices, defined by the elements
+*  of the vectors x, y and z. For i = 1,2,...,n
+*
+*     ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )
+*     ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector x.
+*
+*  Y       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector y.
+*
+*  Z       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector z.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X, Y and Z. INCX > 0.
+*
+*  C       (input) REAL array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) REAL array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX
+      REAL               CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = X( IX )
+         YI = Y( IX )
+         ZI = Z( IX )
+         CI = C( IC )
+         SI = S( IC )
+         T1 = SI*ZI
+         T2 = CI*ZI
+         T3 = T2 - SI*XI
+         T4 = T2 + SI*YI
+         T5 = CI*XI + T1
+         T6 = CI*YI - T1
+         X( IX ) = CI*T5 + SI*T4
+         Y( IX ) = CI*T6 - SI*T3
+         Z( IX ) = CI*T4 - SI*T5
+         IX = IX + INCX
+         IC = IC + INCC
+   10 CONTINUE
+*
+*     End of SLAR2V
+*
+      RETURN
+      END
diff --git a/SRC/slarf.f b/SRC/slarf.f
new file mode 100644
index 00000000..018f6a88
--- /dev/null
+++ b/SRC/slarf.f
@@ -0,0 +1,152 @@
+      SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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
+      REAL               TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARF 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) REAL 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) REAL
+*          The value tau in the representation of H.
+*
+*  C       (input/output) REAL 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) REAL array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            APPLYLEFT
+      INTEGER            I, LASTV, LASTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SGER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILASLR, ILASLC
+      EXTERNAL           LSAME, ILASLR, ILASLC
+*     ..
+*     .. Executable Statements ..
+*
+      APPLYLEFT = LSAME( SIDE, 'L' )
+      LASTV = 0
+      LASTC = 0
+      IF( TAU.NE.ZERO ) THEN
+!     Set up variables for scanning V.  LASTV begins pointing to the end
+!     of V.
+         IF( APPLYLEFT ) THEN
+            LASTV = M
+         ELSE
+            LASTV = N
+         END IF
+         IF( INCV.GT.0 ) THEN
+            I = 1 + (LASTV-1) * INCV
+         ELSE
+            I = 1
+         END IF
+!     Look for the last non-zero row in V.
+         DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
+            LASTV = LASTV - 1
+            I = I - INCV
+         END DO
+         IF( APPLYLEFT ) THEN
+!     Scan for the last non-zero column in C(1:lastv,:).
+            LASTC = ILASLC(LASTV, N, C, LDC)
+         ELSE
+!     Scan for the last non-zero row in C(:,1:lastv).
+            LASTC = ILASLR(M, LASTV, C, LDC)
+         END IF
+      END IF
+!     Note that lastc.eq.0 renders the BLAS operations null; no special
+!     case is needed at this level.
+      IF( APPLYLEFT ) THEN
+*
+*        Form  H * C
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
+*
+            CALL SGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
+     $           ZERO, WORK, 1 )
+*
+*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
+*
+            CALL SGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+            CALL SGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
+     $           V, INCV, ZERO, WORK, 1 )
+*
+*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
+*
+            CALL SGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of SLARF
+*
+      END
diff --git a/SRC/slarfb.f b/SRC/slarfb.f
new file mode 100644
index 00000000..8f503be9
--- /dev/null
+++ b/SRC/slarfb.f
@@ -0,0 +1,641 @@
+      SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+      IMPLICIT NONE
+*
+*  -- 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 ..
+      REAL               C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARFB 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) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, J, LASTV, LASTC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILASLR, ILASLC
+      EXTERNAL           LSAME, ILASLR, ILASLC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, STRMM
+*     ..
+*     .. 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 )
+*
+               LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
+               LASTC = ILASLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL SGEMM( 'Transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                 LASTV-K, LASTC, K,
+     $                 -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+     $                 C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
+               LASTC = ILASLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL SGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, LASTV-K, K,
+     $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+     $                 C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
+               LASTC = ILASLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL SGEMM( 'Transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-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 )
+*
+               LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
+               LASTC = ILASLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL SGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-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 )
+*
+               LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
+               LASTC = ILASLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL SGEMM( 'Transpose', 'Transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL SGEMM( 'Transpose', 'Transpose',
+     $                 LASTV-K, LASTC, K,
+     $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
+     $                 ONE, C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
+               LASTC = ILASLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL SGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-K, K,
+     $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
+     $                 ONE, C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
+               LASTC = ILASLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL SGEMM( 'Transpose', 'Transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL SGEMM( 'Transpose', 'Transpose',
+     $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-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 )
+*
+               LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
+               LASTC = ILASLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL SCOPY( LASTC, C( 1, LASTV-K+J ), 1,
+     $                 WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL SGEMM( 'No transpose', 'Transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL SGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-K+J )
+     $                    - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of SLARFB
+*
+      END
diff --git a/SRC/slarfg.f b/SRC/slarfg.f
new file mode 100644
index 00000000..9f74e7b5
--- /dev/null
+++ b/SRC/slarfg.f
@@ -0,0 +1,133 @@
+      SUBROUTINE SLARFG( 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
+      REAL               ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARFG 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) REAL
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) REAL 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) REAL
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      REAL               BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2, SNRM2
+      EXTERNAL           SLAMCH, SLAPY2, SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.1 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = SNRM2( N-1, X, INCX )
+*
+      IF( XNORM.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
+         SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            RSAFMN = ONE / SAFMIN
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL SSCAL( 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 = SNRM2( N-1, X, INCX )
+            BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
+         END IF
+         TAU = ( BETA-ALPHA ) / BETA
+         CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+*
+*        If ALPHA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of SLARFG
+*
+      END
diff --git a/SRC/slarfp.f b/SRC/slarfp.f
new file mode 100644
index 00000000..c40e32ef
--- /dev/null
+++ b/SRC/slarfp.f
@@ -0,0 +1,154 @@
+      SUBROUTINE SLARFP( 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
+      REAL               ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARFP 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, beta is non-negative, and x is
+*  an (n-1)-element real vector.  H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( 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) REAL
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) REAL 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) REAL
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0E+0, ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      REAL               BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2, SNRM2
+      EXTERNAL           SLAMCH, SLAPY2, SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = SNRM2( N-1, X, INCX )
+*
+      IF( XNORM.EQ.ZERO ) THEN
+*
+*        H  =  [+/-1, 0; I], sign chosen so ALPHA >= 0.
+*
+         IF( ALPHA.GE.ZERO ) THEN
+!           When TAU.eq.ZERO, the vector is special-cased to be
+!           all zeros in the application routines.  We do not need
+!           to clear it.
+            TAU = ZERO
+         ELSE
+!           However, the application routines rely on explicit
+!           zero checks when TAU.ne.ZERO, and we must clear X.
+            TAU = TWO
+            DO J = 1, N-1
+               X( 1 + (J-1)*INCX ) = 0
+            END DO
+            ALPHA = -ALPHA
+         END IF
+      ELSE
+*
+*        general case
+*
+         BETA = SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
+         SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            RSAFMN = ONE / SAFMIN
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL SSCAL( 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 = SNRM2( N-1, X, INCX )
+            BETA = SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
+         END IF
+         ALPHA = ALPHA + BETA
+         IF( BETA.LT.ZERO ) THEN
+            BETA = -BETA
+            TAU = -ALPHA / BETA
+         ELSE
+            ALPHA = XNORM * (XNORM/ALPHA)
+            TAU = ALPHA / BETA
+            ALPHA = -ALPHA
+         END IF
+         CALL SSCAL( N-1, ONE / ALPHA, X, INCX )
+*
+*        If BETA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of SLARFP
+*
+      END
diff --git a/SRC/slarft.f b/SRC/slarft.f
new file mode 100644
index 00000000..879e710d
--- /dev/null
+++ b/SRC/slarft.f
@@ -0,0 +1,251 @@
+      SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+      IMPLICIT NONE
+*
+*  -- 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 ..
+      REAL               T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARFT 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) REAL 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, PREVLASTV, LASTV
+      REAL               VII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, STRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( LSAME( DIRECT, 'F' ) ) THEN
+         PREVLASTV = N
+         DO 20 I = 1, K
+            PREVLASTV = MAX( I, PREVLASTV )
+            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
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( LASTV, I ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i)
+*
+                  CALL SGEMV( 'Transpose', J-I+1, I-1, -TAU( I ),
+     $                        V( I, 1 ), LDV, V( I, I ), 1, ZERO,
+     $                        T( 1, I ), 1 )
+               ELSE
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( I, LASTV ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)'
+*
+                  CALL SGEMV( 'No transpose', I-1, J-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 STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+     $                     LDT, T( 1, I ), 1 )
+               T( I, I ) = TAU( I )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MAX( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   20    CONTINUE
+      ELSE
+         PREVLASTV = 1
+         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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( LASTV, I ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i)
+*
+                     CALL SGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ),
+     $                           V( J, I+1 ), LDV, V( J, 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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( I, LASTV ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)'
+*
+                     CALL SGEMV( 'No transpose', K-I, N-K+I-J+1,
+     $                    -TAU( I ), V( I+1, J ), LDV, V( I, J ), 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 STRMV( '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 )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MIN( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of SLARFT
+*
+      END
diff --git a/SRC/slarfx.f b/SRC/slarfx.f
new file mode 100644
index 00000000..e712d8ae
--- /dev/null
+++ b/SRC/slarfx.f
@@ -0,0 +1,623 @@
+      SUBROUTINE SLARFX( 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
+      REAL               TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARFX 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) REAL array, dimension (M) if SIDE = 'L'
+*                                     or (N) if SIDE = 'R'
+*          The vector v in the representation of H.
+*
+*  TAU     (input) REAL
+*          The value tau in the representation of H.
+*
+*  C       (input/output) REAL 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) REAL array, dimension
+*                      (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*          WORK is not referenced if H has order < 11.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J
+      REAL               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           SLARF
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+         CALL SLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 20 J = 1, N
+            C( 1, J ) = T1*C( 1, J )
+   20    CONTINUE
+         GO TO 410
+   30    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 40 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+   40    CONTINUE
+         GO TO 410
+   50    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 60 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+   60    CONTINUE
+         GO TO 410
+   70    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 80 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+   80    CONTINUE
+         GO TO 410
+   90    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 100 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+  100    CONTINUE
+         GO TO 410
+  110    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 120 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+  120    CONTINUE
+         GO TO 410
+  130    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 140 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+  140    CONTINUE
+         GO TO 410
+  150    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 160 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+  160    CONTINUE
+         GO TO 410
+  170    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 180 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+  180    CONTINUE
+         GO TO 410
+  190    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+         CALL SLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 220 J = 1, M
+            C( J, 1 ) = T1*C( J, 1 )
+  220    CONTINUE
+         GO TO 410
+  230    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 240 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+  240    CONTINUE
+         GO TO 410
+  250    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 260 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+  260    CONTINUE
+         GO TO 410
+  270    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 280 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+  280    CONTINUE
+         GO TO 410
+  290    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 300 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+  300    CONTINUE
+         GO TO 410
+  310    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 320 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+  320    CONTINUE
+         GO TO 410
+  330    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 340 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+  340    CONTINUE
+         GO TO 410
+  350    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 360 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+  360    CONTINUE
+         GO TO 410
+  370    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 380 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+  380    CONTINUE
+         GO TO 410
+  390    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 400 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+     $            V10*C( J, 10 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+            C( J, 10 ) = C( J, 10 ) - SUM*T10
+  400    CONTINUE
+         GO TO 410
+      END IF
+  410 RETURN
+*
+*     End of SLARFX
+*
+      END
diff --git a/SRC/slargv.f b/SRC/slargv.f
new file mode 100644
index 00000000..e75e3152
--- /dev/null
+++ b/SRC/slargv.f
@@ -0,0 +1,99 @@
+      SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARGV generates a vector of real plane rotations, determined by
+*  elements of the real vectors x and y. For i = 1,2,...,n
+*
+*     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )
+*     ( -s(i)  c(i) ) ( y(i) ) = (   0  )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be generated.
+*
+*  X       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCX)
+*          On entry, the vector x.
+*          On exit, x(i) is overwritten by a(i), for i = 1,...,n.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCY)
+*          On entry, the vector y.
+*          On exit, the sines of the plane rotations.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (output) REAL array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX, IY
+      REAL               F, G, T, TT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 10 I = 1, N
+         F = X( IX )
+         G = Y( IY )
+         IF( G.EQ.ZERO ) THEN
+            C( IC ) = ONE
+         ELSE IF( F.EQ.ZERO ) THEN
+            C( IC ) = ZERO
+            Y( IY ) = ONE
+            X( IX ) = G
+         ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
+            T = G / F
+            TT = SQRT( ONE+T*T )
+            C( IC ) = ONE / TT
+            Y( IY ) = T*C( IC )
+            X( IX ) = F*TT
+         ELSE
+            T = F / G
+            TT = SQRT( ONE+T*T )
+            Y( IY ) = ONE / TT
+            C( IC ) = T*Y( IY )
+            X( IX ) = G*TT
+         END IF
+         IC = IC + INCC
+         IY = IY + INCY
+         IX = IX + INCX
+   10 CONTINUE
+      RETURN
+*
+*     End of SLARGV
+*
+      END
diff --git a/SRC/slarnv.f b/SRC/slarnv.f
new file mode 100644
index 00000000..99928623
--- /dev/null
+++ b/SRC/slarnv.f
@@ -0,0 +1,115 @@
+      SUBROUTINE SLARNV( IDIST, ISEED, N, X )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IDIST, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISEED( 4 )
+      REAL               X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARNV returns a vector of n random real numbers from a uniform or
+*  normal distribution.
+*
+*  Arguments
+*  =========
+*
+*  IDIST   (input) INTEGER
+*          Specifies the distribution of the random numbers:
+*          = 1:  uniform (0,1)
+*          = 2:  uniform (-1,1)
+*          = 3:  normal (0,1)
+*
+*  ISEED   (input/output) INTEGER array, dimension (4)
+*          On entry, the seed of the random number generator; the array
+*          elements must be between 0 and 4095, and ISEED(4) must be
+*          odd.
+*          On exit, the seed is updated.
+*
+*  N       (input) INTEGER
+*          The number of random numbers to be generated.
+*
+*  X       (output) REAL array, dimension (N)
+*          The generated random numbers.
+*
+*  Further Details
+*  ===============
+*
+*  This routine calls the auxiliary routine SLARUV to generate random
+*  real numbers from a uniform (0,1) distribution, in batches of up to
+*  128 using vectorisable code. The Box-Muller method is used to
+*  transform numbers from a uniform to a normal distribution.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, TWO
+      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0 )
+      INTEGER            LV
+      PARAMETER          ( LV = 128 )
+      REAL               TWOPI
+      PARAMETER          ( TWOPI = 6.2831853071795864769252867663E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IL, IL2, IV
+*     ..
+*     .. Local Arrays ..
+      REAL               U( LV )
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          COS, LOG, MIN, SQRT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARUV
+*     ..
+*     .. Executable Statements ..
+*
+      DO 40 IV = 1, N, LV / 2
+         IL = MIN( LV / 2, N-IV+1 )
+         IF( IDIST.EQ.3 ) THEN
+            IL2 = 2*IL
+         ELSE
+            IL2 = IL
+         END IF
+*
+*        Call SLARUV to generate IL2 numbers from a uniform (0,1)
+*        distribution (IL2 <= LV)
+*
+         CALL SLARUV( ISEED, IL2, U )
+*
+         IF( IDIST.EQ.1 ) THEN
+*
+*           Copy generated numbers
+*
+            DO 10 I = 1, IL
+               X( IV+I-1 ) = U( I )
+   10       CONTINUE
+         ELSE IF( IDIST.EQ.2 ) THEN
+*
+*           Convert generated numbers to uniform (-1,1) distribution
+*
+            DO 20 I = 1, IL
+               X( IV+I-1 ) = TWO*U( I ) - ONE
+   20       CONTINUE
+         ELSE IF( IDIST.EQ.3 ) THEN
+*
+*           Convert generated numbers to normal (0,1) distribution
+*
+            DO 30 I = 1, IL
+               X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
+     $                       COS( TWOPI*U( 2*I ) )
+   30       CONTINUE
+         END IF
+   40 CONTINUE
+      RETURN
+*
+*     End of SLARNV
+*
+      END
diff --git a/SRC/slarra.f b/SRC/slarra.f
new file mode 100644
index 00000000..5cef365f
--- /dev/null
+++ b/SRC/slarra.f
@@ -0,0 +1,130 @@
+      SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM,
+     $                    NSPLIT, ISPLIT, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N, NSPLIT
+      REAL                SPLTOL, TNRM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISPLIT( * )
+      REAL               D( * ), E( * ), E2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Compute the splitting points with threshold SPLTOL.
+*  SLARRA sets any "small" off-diagonal elements to zero.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  D       (input) REAL             array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal
+*          matrix T.
+*
+*  E       (input/output) REAL             array, dimension (N)
+*          On entry, the first (N-1) entries contain the subdiagonal
+*          elements of the tridiagonal matrix T; E(N) need not be set.
+*          On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
+*          are set to zero, the other entries of E are untouched.
+*
+*  E2      (input/output) REAL             array, dimension (N)
+*          On entry, the first (N-1) entries contain the SQUARES of the
+*          subdiagonal elements of the tridiagonal matrix T;
+*          E2(N) need not be set.
+*          On exit, the entries E2( ISPLIT( I ) ),
+*          1 <= I <= NSPLIT, have been set to zero
+*
+*  SPLTOL (input) REAL            
+*          The threshold for splitting. Two criteria can be used:
+*          SPLTOL<0 : criterion based on absolute off-diagonal value
+*          SPLTOL>0 : criterion that preserves relative accuracy
+*
+*  TNRM (input) REAL            
+*          The norm of the matrix.
+*
+*  NSPLIT  (output) INTEGER
+*          The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+*  ISPLIT  (output) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               EABS, TMP1
+
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+
+*     Compute splitting points
+      NSPLIT = 1
+      IF(SPLTOL.LT.ZERO) THEN
+*        Criterion based on absolute off-diagonal value
+         TMP1 = ABS(SPLTOL)* TNRM
+         DO 9 I = 1, N-1
+            EABS = ABS( E(I) )
+            IF( EABS .LE. TMP1) THEN
+               E(I) = ZERO
+               E2(I) = ZERO
+               ISPLIT( NSPLIT ) = I
+               NSPLIT = NSPLIT + 1
+            END IF
+ 9       CONTINUE
+      ELSE
+*        Criterion that guarantees relative accuracy
+         DO 10 I = 1, N-1
+            EABS = ABS( E(I) )
+            IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
+     $      THEN
+               E(I) = ZERO
+               E2(I) = ZERO
+               ISPLIT( NSPLIT ) = I
+               NSPLIT = NSPLIT + 1
+            END IF
+ 10      CONTINUE
+      ENDIF
+      ISPLIT( NSPLIT ) = N
+
+      RETURN
+*
+*     End of SLARRA
+*
+      END
diff --git a/SRC/slarrb.f b/SRC/slarrb.f
new file mode 100644
index 00000000..4edce688
--- /dev/null
+++ b/SRC/slarrb.f
@@ -0,0 +1,298 @@
+      SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
+     $                   RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
+     $                   PIVMIN, SPDIAM, TWIST, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IFIRST, ILAST, INFO, N, OFFSET, TWIST
+      REAL               PIVMIN, RTOL1, RTOL2, SPDIAM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), LLD( * ), W( * ),
+     $                   WERR( * ), WGAP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given the relatively robust representation(RRR) L D L^T, SLARRB
+*  does "limited" bisection to refine the eigenvalues of L D L^T,
+*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+*  guesses for these eigenvalues are input in W, the corresponding estimate
+*  of the error in these guesses and their gaps are input in WERR
+*  and WGAP, respectively. During bisection, intervals
+*  [left, right] are maintained by storing their mid-points and
+*  semi-widths in the arrays W and WERR respectively.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.
+*
+*  D       (input) REAL             array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D.
+*
+*  LLD     (input) REAL             array, dimension (N-1)
+*          The (N-1) elements L(i)*L(i)*D(i).
+*
+*  IFIRST  (input) INTEGER
+*          The index of the first eigenvalue to be computed.
+*
+*  ILAST   (input) INTEGER
+*          The index of the last eigenvalue to be computed.
+*
+*  RTOL1   (input) REAL            
+*  RTOL2   (input) REAL            
+*          Tolerance for the convergence of the bisection intervals.
+*          An interval [LEFT,RIGHT] has converged if
+*          RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*          where GAP is the (estimated) distance to the nearest
+*          eigenvalue.
+*
+*  OFFSET  (input) INTEGER
+*          Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
+*          through ILAST-OFFSET elements of these arrays are to be used.
+*
+*  W       (input/output) REAL             array, dimension (N)
+*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+*          estimates of the eigenvalues of L D L^T indexed IFIRST throug
+*          ILAST.
+*          On output, these estimates are refined.
+*
+*  WGAP    (input/output) REAL             array, dimension (N-1)
+*          On input, the (estimated) gaps between consecutive
+*          eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
+*          eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
+*          then WGAP(IFIRST-OFFSET) must be set to ZERO.
+*          On output, these gaps are refined.
+*
+*  WERR    (input/output) REAL             array, dimension (N)
+*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+*          the errors in the estimates of the corresponding elements in W.
+*          On output, these errors are refined.
+*
+*  WORK    (workspace) REAL             array, dimension (2*N)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*N)
+*          Workspace.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence.
+*
+*  SPDIAM  (input) DOUBLE PRECISION
+*          The spectral diameter of the matrix.
+*
+*  TWIST   (input) INTEGER
+*          The twist index for the twisted factorization that is used
+*          for the negcount.
+*          TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
+*          TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
+*          TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
+*
+*  INFO    (output) INTEGER
+*          Error flag.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, TWO, HALF
+      PARAMETER        ( ZERO = 0.0E0, TWO = 2.0E0,
+     $                   HALF = 0.5E0 )
+      INTEGER   MAXITR
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
+     $                   OLNINT, PREV, R
+      REAL               BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
+     $                   RGAP, RIGHT, TMP, WIDTH
+*     ..
+*     .. External Functions ..
+      INTEGER            SLANEG
+      EXTERNAL           SLANEG
+*
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+      MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+      MNWDTH = TWO * PIVMIN
+*
+      R = TWIST
+      IF((R.LT.1).OR.(R.GT.N)) R = N
+*
+*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+*     for an unconverged interval is set to the index of the next unconverged
+*     interval, and is -1 or 0 for a converged interval. Thus a linked
+*     list of unconverged intervals is set up.
+*
+      I1 = IFIRST
+*     The number of unconverged intervals
+      NINT = 0
+*     The last unconverged interval found
+      PREV = 0
+
+      RGAP = WGAP( I1-OFFSET )
+      DO 75 I = I1, ILAST
+         K = 2*I
+         II = I - OFFSET
+         LEFT = W( II ) - WERR( II )
+         RIGHT = W( II ) + WERR( II )
+         LGAP = RGAP
+         RGAP = WGAP( II )
+         GAP = MIN( LGAP, RGAP )
+
+*        Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
+*
+*        Do while( NEGCNT(LEFT).GT.I-1 )
+*
+         BACK = WERR( II )
+ 20      CONTINUE
+         NEGCNT = SLANEG( N, D, LLD, LEFT, PIVMIN, R )
+         IF( NEGCNT.GT.I-1 ) THEN
+            LEFT = LEFT - BACK
+            BACK = TWO*BACK
+            GO TO 20
+         END IF
+*
+*        Do while( NEGCNT(RIGHT).LT.I )
+*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
+*
+         BACK = WERR( II )
+ 50      CONTINUE
+
+         NEGCNT = SLANEG( N, D, LLD, RIGHT, PIVMIN, R )
+          IF( NEGCNT.LT.I ) THEN
+             RIGHT = RIGHT + BACK
+             BACK = TWO*BACK
+             GO TO 50
+          END IF
+         WIDTH = HALF*ABS( LEFT - RIGHT )
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+         CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+         IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
+*           This interval has already converged and does not need refinement.
+*           (Note that the gaps might change through refining the
+*            eigenvalues, however, they can only get bigger.)
+*           Remove it from the list.
+            IWORK( K-1 ) = -1
+*           Make sure that I1 always points to the first unconverged interval
+            IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
+            IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
+         ELSE
+*           unconverged interval found
+            PREV = I
+            NINT = NINT + 1
+            IWORK( K-1 ) = I + 1
+            IWORK( K ) = NEGCNT
+         END IF
+         WORK( K-1 ) = LEFT
+         WORK( K ) = RIGHT
+ 75   CONTINUE
+
+*
+*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+*     and while (ITER.LT.MAXITR)
+*
+      ITER = 0
+ 80   CONTINUE
+      PREV = I1 - 1
+      I = I1
+      OLNINT = NINT
+
+      DO 100 IP = 1, OLNINT
+         K = 2*I
+         II = I - OFFSET
+         RGAP = WGAP( II )
+         LGAP = RGAP
+         IF(II.GT.1) LGAP = WGAP( II-1 )
+         GAP = MIN( LGAP, RGAP )
+         NEXT = IWORK( K-1 )
+         LEFT = WORK( K-1 )
+         RIGHT = WORK( K )
+         MID = HALF*( LEFT + RIGHT )
+
+*        semiwidth of interval
+         WIDTH = RIGHT - MID
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+         CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+         IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
+     $       ( ITER.EQ.MAXITR ) )THEN
+*           reduce number of unconverged intervals
+            NINT = NINT - 1
+*           Mark interval as converged.
+            IWORK( K-1 ) = 0
+            IF( I1.EQ.I ) THEN
+               I1 = NEXT
+            ELSE
+*              Prev holds the last unconverged interval previously examined
+               IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+            END IF
+            I = NEXT
+            GO TO 100
+         END IF
+         PREV = I
+*
+*        Perform one bisection step
+*
+         NEGCNT = SLANEG( N, D, LLD, MID, PIVMIN, R )
+         IF( NEGCNT.LE.I-1 ) THEN
+            WORK( K-1 ) = MID
+         ELSE
+            WORK( K ) = MID
+         END IF
+         I = NEXT
+ 100  CONTINUE
+      ITER = ITER + 1
+*     do another loop if there are still unconverged intervals
+*     However, in the last iteration, all intervals are accepted
+*     since this is the best we can do.
+      IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+*     At this point, all the intervals have converged
+      DO 110 I = IFIRST, ILAST
+         K = 2*I
+         II = I - OFFSET
+*        All intervals marked by '0' have been refined.
+         IF( IWORK( K-1 ).EQ.0 ) THEN
+            W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+            WERR( II ) = WORK( K ) - W( II )
+         END IF
+ 110  CONTINUE
+*
+      DO 111 I = IFIRST+1, ILAST
+         K = 2*I
+         II = I - OFFSET
+         WGAP( II-1 ) = MAX( ZERO,
+     $                     W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
+ 111  CONTINUE
+
+      RETURN
+*
+*     End of SLARRB
+*
+      END
diff --git a/SRC/slarrc.f b/SRC/slarrc.f
new file mode 100644
index 00000000..015e7bc3
--- /dev/null
+++ b/SRC/slarrc.f
@@ -0,0 +1,159 @@
+      SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
+     $                            EIGCNT, LCNT, RCNT, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBT
+      INTEGER            EIGCNT, INFO, LCNT, N, RCNT
+      REAL               PIVMIN, VL, VU
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Find the number of eigenvalues of the symmetric tridiagonal matrix T
+*  that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
+*  if JOBT = 'L'.
+*
+*  Arguments
+*  =========
+*
+*  JOBT    (input) CHARACTER*1
+*          = 'T':  Compute Sturm count for matrix T.
+*          = 'L':  Compute Sturm count for matrix L D L^T.
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          The lower and upper bounds for the eigenvalues.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
+*          JOBT = 'L': The N diagonal elements of the diagonal matrix D.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N)
+*          JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
+*          JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence for T.
+*
+*  EIGCNT  (output) INTEGER
+*          The number of eigenvalues of the symmetric tridiagonal matrix T
+*          that are in the interval (VL,VU]
+*
+*  LCNT    (output) INTEGER
+*  RCNT    (output) INTEGER
+*          The left and right negcounts of the interval.
+*
+*  INFO    (output) INTEGER
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      LOGICAL            MATT
+      REAL               LPIVOT, RPIVOT, SL, SU, TMP, TMP2
+
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      LCNT = 0
+      RCNT = 0
+      EIGCNT = 0
+      MATT = LSAME( JOBT, 'T' )
+
+
+      IF (MATT) THEN
+*        Sturm sequence count on T
+         LPIVOT = D( 1 ) - VL
+         RPIVOT = D( 1 ) - VU
+         IF( LPIVOT.LE.ZERO ) THEN
+            LCNT = LCNT + 1
+         ENDIF
+         IF( RPIVOT.LE.ZERO ) THEN
+            RCNT = RCNT + 1
+         ENDIF
+         DO 10 I = 1, N-1
+            TMP = E(I)**2
+            LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
+            RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
+            IF( LPIVOT.LE.ZERO ) THEN
+               LCNT = LCNT + 1
+            ENDIF
+            IF( RPIVOT.LE.ZERO ) THEN
+               RCNT = RCNT + 1
+            ENDIF
+ 10      CONTINUE
+      ELSE
+*        Sturm sequence count on L D L^T
+         SL = -VL
+         SU = -VU
+         DO 20 I = 1, N - 1
+            LPIVOT = D( I ) + SL
+            RPIVOT = D( I ) + SU
+            IF( LPIVOT.LE.ZERO ) THEN
+               LCNT = LCNT + 1
+            ENDIF
+            IF( RPIVOT.LE.ZERO ) THEN
+               RCNT = RCNT + 1
+            ENDIF
+            TMP = E(I) * D(I) * E(I)
+*
+            TMP2 = TMP / LPIVOT
+            IF( TMP2.EQ.ZERO ) THEN
+               SL =  TMP - VL
+            ELSE
+               SL = SL*TMP2 - VL
+            END IF
+*
+            TMP2 = TMP / RPIVOT
+            IF( TMP2.EQ.ZERO ) THEN
+               SU =  TMP - VU
+            ELSE
+               SU = SU*TMP2 - VU
+            END IF
+ 20      CONTINUE
+         LPIVOT = D( N ) + SL
+         RPIVOT = D( N ) + SU
+         IF( LPIVOT.LE.ZERO ) THEN
+            LCNT = LCNT + 1
+         ENDIF
+         IF( RPIVOT.LE.ZERO ) THEN
+            RCNT = RCNT + 1
+         ENDIF
+      ENDIF
+      EIGCNT = RCNT - LCNT
+
+      RETURN
+*
+*     end of SLARRC
+*
+      END
diff --git a/SRC/slarrd.f b/SRC/slarrd.f
new file mode 100644
index 00000000..2a20429b
--- /dev/null
+++ b/SRC/slarrd.f
@@ -0,0 +1,713 @@
+      SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
+     $                    RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+     $                    M, W, WERR, WL, WU, IBLOCK, INDEXW,
+     $                    WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          ORDER, RANGE
+      INTEGER            IL, INFO, IU, M, N, NSPLIT
+      REAL                PIVMIN, RELTOL, VL, VU, WL, WU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), INDEXW( * ),
+     $                   ISPLIT( * ), IWORK( * )
+      REAL               D( * ), E( * ), E2( * ),
+     $                   GERS( * ), W( * ), WERR( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARRD computes the eigenvalues of a symmetric tridiagonal
+*  matrix T to suitable accuracy. This is an auxiliary code to be
+*  called from SSTEMR.
+*  The user may ask for all eigenvalues, all eigenvalues
+*  in the half-open interval (VL, VU], or the IL-th through IU-th
+*  eigenvalues.
+*
+*  To avoid overflow, the matrix must be scaled so that its
+*  largest element is no greater than overflow**(1/2) *
+*  underflow**(1/4) in absolute value, and for greatest
+*  accuracy, it should not be much smaller than that.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966.
+*
+*  Arguments
+*  =========
+*
+*  RANGE   (input) CHARACTER
+*          = 'A': ("All")   all eigenvalues will be found.
+*          = 'V': ("Value") all eigenvalues in the half-open interval
+*                           (VL, VU] will be found.
+*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+*                           entire matrix) will be found.
+*
+*  ORDER   (input) CHARACTER
+*          = 'B': ("By Block") the eigenvalues will be grouped by
+*                              split-off block (see IBLOCK, ISPLIT) and
+*                              ordered from smallest to largest within
+*                              the block.
+*          = 'E': ("Entire matrix")
+*                              the eigenvalues for the entire matrix
+*                              will be ordered from smallest to
+*                              largest.
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal matrix T.  N >= 0.
+*
+*  VL      (input) REAL            
+*  VU      (input) REAL            
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues.  Eigenvalues less than or equal
+*          to VL, or greater than VU, will not be returned.  VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  GERS    (input) REAL             array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)).
+*
+*  RELTOL  (input) REAL            
+*          The minimum relative width of an interval.  When an interval
+*          is narrower than RELTOL times the larger (in
+*          magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  Note: this should
+*          always be at least radix*machine epsilon.
+*
+*  D       (input) REAL             array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) REAL             array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+*  E2      (input) REAL             array, dimension (N-1)
+*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+*  PIVMIN  (input) REAL            
+*          The minimum pivot allowed in the Sturm sequence for T.
+*
+*  NSPLIT  (input) INTEGER
+*          The number of diagonal blocks in the matrix T.
+*          1 <= NSPLIT <= N.
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*          (Only the first NSPLIT elements will actually be used, but
+*          since the user cannot know a priori what value NSPLIT will
+*          have, N words must be reserved for ISPLIT.)
+*
+*  M       (output) INTEGER
+*          The actual number of eigenvalues found. 0 <= M <= N.
+*          (See also the description of INFO=2,3.)
+*
+*  W       (output) REAL             array, dimension (N)
+*          On exit, the first M elements of W will contain the
+*          eigenvalue approximations. SLARRD computes an interval
+*          I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
+*          approximation is given as the interval midpoint
+*          W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
+*          WERR(j) = abs( a_j - b_j)/2
+*
+*  WERR    (output) REAL             array, dimension (N)
+*          The error bound on the corresponding eigenvalue approximation
+*          in W.
+*
+*  WL      (output) REAL            
+*  WU      (output) REAL            
+*          The interval (WL, WU] contains all the wanted eigenvalues.
+*          If RANGE='V', then WL=VL and WU=VU.
+*          If RANGE='A', then WL and WU are the global Gerschgorin bounds
+*                        on the spectrum.
+*          If RANGE='I', then WL and WU are computed by SLAEBZ from the
+*                        index range specified.
+*
+*  IBLOCK  (output) INTEGER array, dimension (N)
+*          At each row/column j where E(j) is zero or small, the
+*          matrix T is considered to split into a block diagonal
+*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which
+*          block (from 1 to the number of blocks) the eigenvalue W(i)
+*          belongs.  (SLARRD may use the remaining N-M elements as
+*          workspace.)
+*
+*  INDEXW  (output) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
+*          i-th eigenvalue W(i) is the j-th eigenvalue in block k.
+*
+*  WORK    (workspace) REAL             array, dimension (4*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  some or all of the eigenvalues failed to converge or
+*                were not computed:
+*                =1 or 3: Bisection failed to converge for some
+*                        eigenvalues; these eigenvalues are flagged by a
+*                        negative block number.  The effect is that the
+*                        eigenvalues may not be as accurate as the
+*                        absolute and relative tolerances.  This is
+*                        generally caused by unexpectedly inaccurate
+*                        arithmetic.
+*                =2 or 3: RANGE='I' only: Not all of the eigenvalues
+*                        IL:IU were found.
+*                        Effect: M < IU+1-IL
+*                        Cause:  non-monotonic arithmetic, causing the
+*                                Sturm sequence to be non-monotonic.
+*                        Cure:   recalculate, using RANGE='A', and pick
+*                                out eigenvalues IL:IU.  In some cases,
+*                                increasing the PARAMETER "FUDGE" may
+*                                make things work.
+*                = 4:    RANGE='I', and the Gershgorin interval
+*                        initially used was too small.  No eigenvalues
+*                        were computed.
+*                        Probable cause: your machine has sloppy
+*                                        floating-point arithmetic.
+*                        Cure: Increase the PARAMETER "FUDGE",
+*                              recompile, and try again.
+*
+*  Internal Parameters
+*  ===================
+*
+*  FUDGE   REAL            , default = 2
+*          A "fudge factor" to widen the Gershgorin intervals.  Ideally,
+*          a value of 1 should work, but on machines with sloppy
+*          arithmetic, this needs to be larger.  The default for
+*          publicly released versions should be large enough to handle
+*          the worst machine around.  Note that this has no effect
+*          on accuracy of the solution.
+*
+*  Based on contributions by
+*     W. Kahan, University of California, Berkeley, USA
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, HALF, FUDGE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
+     $                     TWO = 2.0E0, HALF = ONE/TWO,
+     $                     FUDGE = TWO )
+      INTEGER   ALLRNG, VALRNG, INDRNG
+      PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NCNVRG, TOOFEW
+      INTEGER            I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+     $                   IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
+     $                   ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
+     $                   NWL, NWU
+      REAL               ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
+     $                   TNORM, UFLOW, WKILL, WLU, WUL
+
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUMMA( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ILAENV, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAEBZ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Decode RANGE
+*
+      IF( LSAME( RANGE, 'A' ) ) THEN
+         IRANGE = ALLRNG
+      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+         IRANGE = VALRNG
+      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+         IRANGE = INDRNG
+      ELSE
+         IRANGE = 0
+      END IF
+*
+*     Check for Errors
+*
+      IF( IRANGE.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( IRANGE.EQ.VALRNG ) THEN
+         IF( VL.GE.VU )
+     $      INFO = -5
+      ELSE IF( IRANGE.EQ.INDRNG .AND.
+     $        ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      ELSE IF( IRANGE.EQ.INDRNG .AND.
+     $        ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         RETURN
+      END IF
+
+*     Initialize error flags
+      INFO = 0
+      NCNVRG = .FALSE.
+      TOOFEW = .FALSE.
+
+*     Quick return if possible
+      M = 0
+      IF( N.EQ.0 ) RETURN
+
+*     Simplification:
+      IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
+
+*     Get machine constants
+      EPS = SLAMCH( 'P' )
+      UFLOW = SLAMCH( 'U' )
+
+
+*     Special Case when N=1
+*     Treat case of 1x1 matrix for quick return
+      IF( N.EQ.1 ) THEN
+         IF( (IRANGE.EQ.ALLRNG).OR.
+     $       ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+     $       ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+            M = 1
+            W(1) = D(1)
+*           The computation error of the eigenvalue is zero
+            WERR(1) = ZERO
+            IBLOCK( 1 ) = 1
+            INDEXW( 1 ) = 1
+         ENDIF
+         RETURN
+      END IF
+
+*     NB is the minimum vector length for vector bisection, or 0
+*     if only scalar is to be done.
+      NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
+      IF( NB.LE.1 ) NB = 0
+
+*     Find global spectral radius
+      GL = D(1)
+      GU = D(1)
+      DO 5 I = 1,N
+         GL =  MIN( GL, GERS( 2*I - 1))
+         GU = MAX( GU, GERS(2*I) )
+ 5    CONTINUE
+*     Compute global Gerschgorin bounds and spectral diameter
+      TNORM = MAX( ABS( GL ), ABS( GU ) )
+      GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+      GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+      SPDIAM = GU - GL
+*     Input arguments for SLAEBZ:
+*     The relative tolerance.  An interval (a,b] lies within
+*     "relative tolerance" if  b-a < RELTOL*max(|a|,|b|),
+      RTOLI = RELTOL
+*     Set the absolute tolerance for interval convergence to zero to force
+*     interval convergence based on relative size of the interval.
+*     This is dangerous because intervals might not converge when RELTOL is
+*     small. But at least a very small number should be selected so that for
+*     strongly graded matrices, the code can get relatively accurate
+*     eigenvalues.
+      ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
+
+      IF( IRANGE.EQ.INDRNG ) THEN
+
+*        RANGE='I': Compute an interval containing eigenvalues
+*        IL through IU. The initial interval [GL,GU] from the global
+*        Gerschgorin bounds GL and GU is refined by SLAEBZ.
+         ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+         WORK( N+1 ) = GL
+         WORK( N+2 ) = GL
+         WORK( N+3 ) = GU
+         WORK( N+4 ) = GU
+         WORK( N+5 ) = GL
+         WORK( N+6 ) = GU
+         IWORK( 1 ) = -1
+         IWORK( 2 ) = -1
+         IWORK( 3 ) = N + 1
+         IWORK( 4 ) = N + 1
+         IWORK( 5 ) = IL - 1
+         IWORK( 6 ) = IU
+*
+         CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN,
+     $         D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+     $                IWORK, W, IBLOCK, IINFO )
+         IF( IINFO .NE. 0 ) THEN
+            INFO = IINFO
+            RETURN
+         END IF
+*        On exit, output intervals may not be ordered by ascending negcount
+         IF( IWORK( 6 ).EQ.IU ) THEN
+            WL = WORK( N+1 )
+            WLU = WORK( N+3 )
+            NWL = IWORK( 1 )
+            WU = WORK( N+4 )
+            WUL = WORK( N+2 )
+            NWU = IWORK( 4 )
+         ELSE
+            WL = WORK( N+2 )
+            WLU = WORK( N+4 )
+            NWL = IWORK( 2 )
+            WU = WORK( N+3 )
+            WUL = WORK( N+1 )
+            NWU = IWORK( 3 )
+         END IF
+*        On exit, the interval [WL, WLU] contains a value with negcount NWL,
+*        and [WUL, WU] contains a value with negcount NWU.
+         IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+            INFO = 4
+            RETURN
+         END IF
+
+      ELSEIF( IRANGE.EQ.VALRNG ) THEN
+         WL = VL
+         WU = VU
+
+      ELSEIF( IRANGE.EQ.ALLRNG ) THEN
+         WL = GL
+         WU = GU
+      ENDIF
+
+
+
+*     Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
+*     NWL accumulates the number of eigenvalues .le. WL,
+*     NWU accumulates the number of eigenvalues .le. WU
+      M = 0
+      IEND = 0
+      INFO = 0
+      NWL = 0
+      NWU = 0
+*
+      DO 70 JBLK = 1, NSPLIT
+         IOFF = IEND
+         IBEGIN = IOFF + 1
+         IEND = ISPLIT( JBLK )
+         IN = IEND - IOFF
+*
+         IF( IN.EQ.1 ) THEN
+*           1x1 block
+            IF( WL.GE.D( IBEGIN )-PIVMIN )
+     $         NWL = NWL + 1
+            IF( WU.GE.D( IBEGIN )-PIVMIN )
+     $         NWU = NWU + 1
+            IF( IRANGE.EQ.ALLRNG .OR.
+     $           ( WL.LT.D( IBEGIN )-PIVMIN
+     $             .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
+               M = M + 1
+               W( M ) = D( IBEGIN )
+               WERR(M) = ZERO
+*              The gap for a single block doesn't matter for the later
+*              algorithm and is assigned an arbitrary large value
+               IBLOCK( M ) = JBLK
+               INDEXW( M ) = 1
+            END IF
+
+*        Disabled 2x2 case because of a failure on the following matrix
+*        RANGE = 'I', IL = IU = 4
+*          Original Tridiagonal, d = [
+*           -0.150102010615740E+00
+*           -0.849897989384260E+00
+*           -0.128208148052635E-15
+*            0.128257718286320E-15
+*          ];
+*          e = [
+*           -0.357171383266986E+00
+*           -0.180411241501588E-15
+*           -0.175152352710251E-15
+*          ];
+*
+*         ELSE IF( IN.EQ.2 ) THEN
+**           2x2 block
+*            DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
+*            TMP1 = HALF*(D(IBEGIN)+D(IEND))
+*            L1 = TMP1 - DISC
+*            IF( WL.GE. L1-PIVMIN )
+*     $         NWL = NWL + 1
+*            IF( WU.GE. L1-PIVMIN )
+*     $         NWU = NWU + 1
+*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
+*     $          L1-PIVMIN ) ) THEN
+*               M = M + 1
+*               W( M ) = L1
+**              The uncertainty of eigenvalues of a 2x2 matrix is very small
+*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
+*               IBLOCK( M ) = JBLK
+*               INDEXW( M ) = 1
+*            ENDIF
+*            L2 = TMP1 + DISC
+*            IF( WL.GE. L2-PIVMIN )
+*     $         NWL = NWL + 1
+*            IF( WU.GE. L2-PIVMIN )
+*     $         NWU = NWU + 1
+*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
+*     $          L2-PIVMIN ) ) THEN
+*               M = M + 1
+*               W( M ) = L2
+**              The uncertainty of eigenvalues of a 2x2 matrix is very small
+*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
+*               IBLOCK( M ) = JBLK
+*               INDEXW( M ) = 2
+*            ENDIF
+         ELSE
+*           General Case - block of size IN >= 2
+*           Compute local Gerschgorin interval and use it as the initial
+*           interval for SLAEBZ
+            GU = D( IBEGIN )
+            GL = D( IBEGIN )
+            TMP1 = ZERO
+
+            DO 40 J = IBEGIN, IEND
+               GL =  MIN( GL, GERS( 2*J - 1))
+               GU = MAX( GU, GERS(2*J) )
+   40       CONTINUE
+            SPDIAM = GU - GL
+            GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
+            GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
+*
+            IF( IRANGE.GT.1 ) THEN
+               IF( GU.LT.WL ) THEN
+*                 the local block contains none of the wanted eigenvalues
+                  NWL = NWL + IN
+                  NWU = NWU + IN
+                  GO TO 70
+               END IF
+*              refine search interval if possible, only range (WL,WU] matters
+               GL = MAX( GL, WL )
+               GU = MIN( GU, WU )
+               IF( GL.GE.GU )
+     $            GO TO 70
+            END IF
+
+*           Find negcount of initial interval boundaries GL and GU
+            WORK( N+1 ) = GL
+            WORK( N+IN+1 ) = GU
+            CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+            IF( IINFO .NE. 0 ) THEN
+               INFO = IINFO
+               RETURN
+            END IF
+*
+            NWL = NWL + IWORK( 1 )
+            NWU = NWU + IWORK( IN+1 )
+            IWOFF = M - IWORK( 1 )
+
+*           Compute Eigenvalues
+            ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+     $              LOG( TWO ) ) + 2
+            CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+            IF( IINFO .NE. 0 ) THEN
+               INFO = IINFO
+               RETURN
+            END IF
+*
+*           Copy eigenvalues into W and IBLOCK
+*           Use -JBLK for block number for unconverged eigenvalues.
+*           Loop over the number of output intervals from SLAEBZ
+            DO 60 J = 1, IOUT
+*              eigenvalue approximation is middle point of interval
+               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+*              semi length of error interval
+               TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
+               IF( J.GT.IOUT-IINFO ) THEN
+*                 Flag non-convergence.
+                  NCNVRG = .TRUE.
+                  IB = -JBLK
+               ELSE
+                  IB = JBLK
+               END IF
+               DO 50 JE = IWORK( J ) + 1 + IWOFF,
+     $                 IWORK( J+IN ) + IWOFF
+                  W( JE ) = TMP1
+                  WERR( JE ) = TMP2
+                  INDEXW( JE ) = JE - IWOFF
+                  IBLOCK( JE ) = IB
+   50          CONTINUE
+   60       CONTINUE
+*
+            M = M + IM
+         END IF
+   70 CONTINUE
+
+*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+      IF( IRANGE.EQ.INDRNG ) THEN
+         IDISCL = IL - 1 - NWL
+         IDISCU = NWU - IU
+*
+         IF( IDISCL.GT.0 ) THEN
+            IM = 0
+            DO 80 JE = 1, M
+*              Remove some of the smallest eigenvalues from the left so that
+*              at the end IDISCL =0. Move all eigenvalues up to the left.
+               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+                  IDISCL = IDISCL - 1
+               ELSE
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  WERR( IM ) = WERR( JE )
+                  INDEXW( IM ) = INDEXW( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+ 80         CONTINUE
+            M = IM
+         END IF
+         IF( IDISCU.GT.0 ) THEN
+*           Remove some of the largest eigenvalues from the right so that
+*           at the end IDISCU =0. Move all eigenvalues up to the left.
+            IM=M+1
+            DO 81 JE = M, 1, -1
+               IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+                  IDISCU = IDISCU - 1
+               ELSE
+                  IM = IM - 1
+                  W( IM ) = W( JE )
+                  WERR( IM ) = WERR( JE )
+                  INDEXW( IM ) = INDEXW( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+ 81         CONTINUE
+            JEE = 0
+            DO 82 JE = IM, M
+               JEE = JEE + 1
+               W( JEE ) = W( JE )
+               WERR( JEE ) = WERR( JE )
+               INDEXW( JEE ) = INDEXW( JE )
+               IBLOCK( JEE ) = IBLOCK( JE )
+ 82         CONTINUE
+            M = M-IM+1
+         END IF
+
+         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+*           Code to deal with effects of bad arithmetic. (If N(w) is
+*           monotone non-decreasing, this should never happen.)
+*           Some low eigenvalues to be discarded are not in (WL,WLU],
+*           or high eigenvalues to be discarded are not in (WUL,WU]
+*           so just kill off the smallest IDISCL/largest IDISCU
+*           eigenvalues, by marking the corresponding IBLOCK = 0
+            IF( IDISCL.GT.0 ) THEN
+               WKILL = WU
+               DO 100 JDISC = 1, IDISCL
+                  IW = 0
+                  DO 90 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                    ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+ 90               CONTINUE
+                  IBLOCK( IW ) = 0
+ 100           CONTINUE
+            END IF
+            IF( IDISCU.GT.0 ) THEN
+               WKILL = WL
+               DO 120 JDISC = 1, IDISCU
+                  IW = 0
+                  DO 110 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                    ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+ 110              CONTINUE
+                  IBLOCK( IW ) = 0
+ 120           CONTINUE
+            END IF
+*           Now erase all eigenvalues with IBLOCK set to zero
+            IM = 0
+            DO 130 JE = 1, M
+               IF( IBLOCK( JE ).NE.0 ) THEN
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  WERR( IM ) = WERR( JE )
+                  INDEXW( IM ) = INDEXW( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+ 130        CONTINUE
+            M = IM
+         END IF
+         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+            TOOFEW = .TRUE.
+         END IF
+      END IF
+*
+      IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
+     $   ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
+         TOOFEW = .TRUE.
+      END IF
+
+*     If ORDER='B', do nothing the eigenvalues are already sorted by
+*        block.
+*     If ORDER='E', sort the eigenvalues from smallest to largest
+
+      IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN
+         DO 150 JE = 1, M - 1
+            IE = 0
+            TMP1 = W( JE )
+            DO 140 J = JE + 1, M
+               IF( W( J ).LT.TMP1 ) THEN
+                  IE = J
+                  TMP1 = W( J )
+               END IF
+  140       CONTINUE
+            IF( IE.NE.0 ) THEN
+               TMP2 = WERR( IE )
+               ITMP1 = IBLOCK( IE )
+               ITMP2 = INDEXW( IE )
+               W( IE ) = W( JE )
+               WERR( IE ) = WERR( JE )
+               IBLOCK( IE ) = IBLOCK( JE )
+               INDEXW( IE ) = INDEXW( JE )
+               W( JE ) = TMP1
+               WERR( JE ) = TMP2
+               IBLOCK( JE ) = ITMP1
+               INDEXW( JE ) = ITMP2
+            END IF
+  150    CONTINUE
+      END IF
+*
+      INFO = 0
+      IF( NCNVRG )
+     $   INFO = INFO + 1
+      IF( TOOFEW )
+     $   INFO = INFO + 2
+      RETURN
+*
+*     End of SLARRD
+*
+      END
diff --git a/SRC/slarre.f b/SRC/slarre.f
new file mode 100644
index 00000000..a7978e2d
--- /dev/null
+++ b/SRC/slarre.f
@@ -0,0 +1,756 @@
+      SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
+     $                    RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
+     $                    W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
+     $                    WORK, IWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          RANGE
+      INTEGER            IL, INFO, IU, M, N, NSPLIT
+      REAL              PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+     $                   INDEXW( * )
+      REAL               D( * ), E( * ), E2( * ), GERS( * ),
+     $                   W( * ),WERR( * ), WGAP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  To find the desired eigenvalues of a given real symmetric
+*  tridiagonal matrix T, SLARRE sets any "small" off-diagonal
+*  elements to zero, and for each unreduced block T_i, it finds
+*  (a) a suitable shift at one end of the block's spectrum,
+*  (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
+*  (c) eigenvalues of each L_i D_i L_i^T.
+*  The representations and eigenvalues found are then used by
+*  SSTEMR to compute the eigenvectors of T.
+*  The accuracy varies depending on whether bisection is used to
+*  find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
+*  conpute all and then discard any unwanted one.
+*  As an added benefit, SLARRE also outputs the n
+*  Gerschgorin intervals for the matrices L_i D_i L_i^T.
+*
+*  Arguments
+*  =========
+*
+*  RANGE   (input) CHARACTER
+*          = 'A': ("All")   all eigenvalues will be found.
+*          = 'V': ("Value") all eigenvalues in the half-open interval
+*                           (VL, VU] will be found.
+*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+*                           entire matrix) will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  VL      (input/output) REAL            
+*  VU      (input/output) REAL            
+*          If RANGE='V', the lower and upper bounds for the eigenvalues.
+*          Eigenvalues less than or equal to VL, or greater than VU,
+*          will not be returned.  VL < VU.
+*          If RANGE='I' or ='A', SLARRE computes bounds on the desired
+*          part of the spectrum.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N.
+*
+*  D       (input/output) REAL             array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal
+*          matrix T.
+*          On exit, the N diagonal elements of the diagonal
+*          matrices D_i.
+*
+*  E       (input/output) REAL             array, dimension (N)
+*          On entry, the first (N-1) entries contain the subdiagonal
+*          elements of the tridiagonal matrix T; E(N) need not be set.
+*          On exit, E contains the subdiagonal elements of the unit
+*          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+*          1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+*  E2      (input/output) REAL             array, dimension (N)
+*          On entry, the first (N-1) entries contain the SQUARES of the
+*          subdiagonal elements of the tridiagonal matrix T;
+*          E2(N) need not be set.
+*          On exit, the entries E2( ISPLIT( I ) ),
+*          1 <= I <= NSPLIT, have been set to zero
+*
+*  RTOL1   (input) REAL            
+*  RTOL2   (input) REAL            
+*           Parameters for bisection.
+*           An interval [LEFT,RIGHT] has converged if
+*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+*  SPLTOL (input) REAL            
+*          The threshold for splitting.
+*
+*  NSPLIT  (output) INTEGER
+*          The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+*  ISPLIT  (output) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues (of all L_i D_i L_i^T)
+*          found.
+*
+*  W       (output) REAL             array, dimension (N)
+*          The first M elements contain the eigenvalues. The
+*          eigenvalues of each of the blocks, L_i D_i L_i^T, are
+*          sorted in ascending order ( SLARRE may use the
+*          remaining N-M elements as workspace).
+*
+*  WERR    (output) REAL             array, dimension (N)
+*          The error bound on the corresponding eigenvalue in W.
+*
+*  WGAP    (output) REAL             array, dimension (N)
+*          The separation from the right neighbor eigenvalue in W.
+*          The gap is only with respect to the eigenvalues of the same block
+*          as each block has its own representation tree.
+*          Exception: at the right end of a block we store the left gap
+*
+*  IBLOCK  (output) INTEGER array, dimension (N)
+*          The indices of the blocks (submatrices) associated with the
+*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+*          W(i) belongs to the first block from the top, =2 if W(i)
+*          belongs to the second block, etc.
+*
+*  INDEXW  (output) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+*          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+*  GERS    (output) REAL             array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)).
+*
+*  PIVMIN  (output) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence for T.
+*
+*  WORK    (workspace) REAL             array, dimension (6*N)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*          Workspace.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          > 0:  A problem occured in SLARRE.
+*          < 0:  One of the called subroutines signaled an internal problem.
+*                Needs inspection of the corresponding parameter IINFO
+*                for further information.
+*
+*          =-1:  Problem in SLARRD.
+*          = 2:  No base representation could be found in MAXTRY iterations.
+*                Increasing MAXTRY and recompilation might be a remedy.
+*          =-3:  Problem in SLARRB when computing the refined root
+*                representation for SLASQ2.
+*          =-4:  Problem in SLARRB when preforming bisection on the
+*                desired part of the spectrum.
+*          =-5:  Problem in SLASQ2.
+*          =-6:  Problem in SLASQ2.
+*
+*  Further Details
+*  The base representations are required to suffer very little
+*  element growth and consequently define all their eigenvalues to
+*  high relative accuracy.
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
+     $                   MAXGROWTH, ONE, PERT, TWO, ZERO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
+     $                     TWO = 2.0E0, FOUR=4.0E0,
+     $                     HNDRD = 100.0E0,
+     $                     PERT = 4.0E0,
+     $                     HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
+     $                     MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
+      INTEGER            MAXTRY, ALLRNG, INDRNG, VALRNG
+      PARAMETER          ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
+     $                     VALRNG = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORCEB, NOREP, USEDQD
+      INTEGER            CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+     $                   IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+     $                   WBEGIN, WEND
+      REAL               AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
+     $                   EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
+     $                   RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
+     $                   TAU, TMP, TMP1
+
+
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL                        SLAMCH
+      EXTERNAL           SLAMCH, LSAME
+
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLARNV, SLARRA, SLARRB, SLARRC, SLARRD,
+     $                   SLASQ2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+
+*     ..
+*     .. Executable Statements ..
+*
+
+      INFO = 0
+
+*
+*     Decode RANGE
+*
+      IF( LSAME( RANGE, 'A' ) ) THEN
+         IRANGE = ALLRNG
+      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+         IRANGE = VALRNG
+      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+         IRANGE = INDRNG
+      END IF
+
+      M = 0
+
+*     Get machine constants
+      SAFMIN = SLAMCH( 'S' )
+      EPS = SLAMCH( 'P' )
+
+*     Set parameters
+      RTL = HNDRD*EPS
+*     If one were ever to ask for less initial precision in BSRTOL,
+*     one should keep in mind that for the subset case, the extremal
+*     eigenvalues must be at least as accurate as the current setting
+*     (eigenvalues in the middle need not as much accuracy)
+      BSRTOL = SQRT(EPS)*(0.5E-3)
+
+*     Treat case of 1x1 matrix for quick return
+      IF( N.EQ.1 ) THEN
+         IF( (IRANGE.EQ.ALLRNG).OR.
+     $       ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+     $       ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+            M = 1
+            W(1) = D(1)
+*           The computation error of the eigenvalue is zero
+            WERR(1) = ZERO
+            WGAP(1) = ZERO
+            IBLOCK( 1 ) = 1
+            INDEXW( 1 ) = 1
+            GERS(1) = D( 1 )
+            GERS(2) = D( 1 )
+         ENDIF
+*        store the shift for the initial RRR, which is zero in this case
+         E(1) = ZERO
+         RETURN
+      END IF
+
+*     General case: tridiagonal matrix of order > 1
+*
+*     Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
+*     Compute maximum off-diagonal entry and pivmin.
+      GL = D(1)
+      GU = D(1)
+      EOLD = ZERO
+      EMAX = ZERO
+      E(N) = ZERO
+      DO 5 I = 1,N
+         WERR(I) = ZERO
+         WGAP(I) = ZERO
+         EABS = ABS( E(I) )
+         IF( EABS .GE. EMAX ) THEN
+            EMAX = EABS
+         END IF
+         TMP1 = EABS + EOLD
+         GERS( 2*I-1) = D(I) - TMP1
+         GL =  MIN( GL, GERS( 2*I - 1))
+         GERS( 2*I ) = D(I) + TMP1
+         GU = MAX( GU, GERS(2*I) )
+         EOLD  = EABS
+ 5    CONTINUE
+*     The minimum pivot allowed in the Sturm sequence for T
+      PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
+*     Compute spectral diameter. The Gerschgorin bounds give an
+*     estimate that is wrong by at most a factor of SQRT(2)
+      SPDIAM = GU - GL
+
+*     Compute splitting points
+      CALL SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
+     $                    NSPLIT, ISPLIT, IINFO )
+
+*     Can force use of bisection instead of faster DQDS.
+*     Option left in the code for future multisection work.
+      FORCEB = .FALSE.
+
+*     Initialize USEDQD, DQDS should be used for ALLRNG unless someone
+*     explicitly wants bisection.
+      USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB))
+
+      IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
+*        Set interval [VL,VU] that contains all eigenvalues
+         VL = GL
+         VU = GU
+      ELSE
+*        We call SLARRD to find crude approximations to the eigenvalues
+*        in the desired range. In case IRANGE = INDRNG, we also obtain the
+*        interval (VL,VU] that contains all the wanted eigenvalues.
+*        An interval [LEFT,RIGHT] has converged if
+*        RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
+*        SLARRD needs a WORK of size 4*N, IWORK of size 3*N
+         CALL SLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
+     $                    BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+     $                    MM, W, WERR, VL, VU, IBLOCK, INDEXW,
+     $                    WORK, IWORK, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = -1
+            RETURN
+         ENDIF
+*        Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
+         DO 14 I = MM+1,N
+            W( I ) = ZERO
+            WERR( I ) = ZERO
+            IBLOCK( I ) = 0
+            INDEXW( I ) = 0
+ 14      CONTINUE
+      END IF
+
+
+***
+*     Loop over unreduced blocks
+      IBEGIN = 1
+      WBEGIN = 1
+      DO 170 JBLK = 1, NSPLIT
+         IEND = ISPLIT( JBLK )
+         IN = IEND - IBEGIN + 1
+
+*        1 X 1 block
+         IF( IN.EQ.1 ) THEN
+            IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
+     $         ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+     $        .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
+     $        ) THEN
+               M = M + 1
+               W( M ) = D( IBEGIN )
+               WERR(M) = ZERO
+*              The gap for a single block doesn't matter for the later
+*              algorithm and is assigned an arbitrary large value
+               WGAP(M) = ZERO
+               IBLOCK( M ) = JBLK
+               INDEXW( M ) = 1
+               WBEGIN = WBEGIN + 1
+            ENDIF
+*           E( IEND ) holds the shift for the initial RRR
+            E( IEND ) = ZERO
+            IBEGIN = IEND + 1
+            GO TO 170
+         END IF
+*
+*        Blocks of size larger than 1x1
+*
+*        E( IEND ) will hold the shift for the initial RRR, for now set it =0
+         E( IEND ) = ZERO
+*
+*        Find local outer bounds GL,GU for the block
+         GL = D(IBEGIN)
+         GU = D(IBEGIN)
+         DO 15 I = IBEGIN , IEND
+            GL = MIN( GERS( 2*I-1 ), GL )
+            GU = MAX( GERS( 2*I ), GU )
+ 15      CONTINUE
+         SPDIAM = GU - GL
+
+         IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
+*           Count the number of eigenvalues in the current block.
+            MB = 0
+            DO 20 I = WBEGIN,MM
+               IF( IBLOCK(I).EQ.JBLK ) THEN
+                  MB = MB+1
+               ELSE
+                  GOTO 21
+               ENDIF
+ 20         CONTINUE
+ 21         CONTINUE
+
+            IF( MB.EQ.0) THEN
+*              No eigenvalue in the current block lies in the desired range
+*              E( IEND ) holds the shift for the initial RRR
+               E( IEND ) = ZERO
+               IBEGIN = IEND + 1
+               GO TO 170
+            ELSE
+
+*              Decide whether dqds or bisection is more efficient
+               USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
+               WEND = WBEGIN + MB - 1
+*              Calculate gaps for the current block
+*              In later stages, when representations for individual
+*              eigenvalues are different, we use SIGMA = E( IEND ).
+               SIGMA = ZERO
+               DO 30 I = WBEGIN, WEND - 1
+                  WGAP( I ) = MAX( ZERO,
+     $                        W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 30            CONTINUE
+               WGAP( WEND ) = MAX( ZERO,
+     $                     VU - SIGMA - (W( WEND )+WERR( WEND )))
+*              Find local index of the first and last desired evalue.
+               INDL = INDEXW(WBEGIN)
+               INDU = INDEXW( WEND )
+            ENDIF
+         ENDIF
+         IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
+*           Case of DQDS
+*           Find approximations to the extremal eigenvalues of the block
+            CALL SLARRK( IN, 1, GL, GU, D(IBEGIN),
+     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = -1
+               RETURN
+            ENDIF
+            ISLEFT = MAX(GL, TMP - TMP1
+     $               - HNDRD * EPS* ABS(TMP - TMP1))
+
+            CALL SLARRK( IN, IN, GL, GU, D(IBEGIN),
+     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = -1
+               RETURN
+            ENDIF
+            ISRGHT = MIN(GU, TMP + TMP1
+     $                 + HNDRD * EPS * ABS(TMP + TMP1))
+*           Improve the estimate of the spectral diameter
+            SPDIAM = ISRGHT - ISLEFT
+         ELSE
+*           Case of bisection
+*           Find approximations to the wanted extremal eigenvalues
+            ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
+     $                  - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
+            ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
+     $                  + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
+         ENDIF
+
+
+*        Decide whether the base representation for the current block
+*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
+*        should be on the left or the right end of the current block.
+*        The strategy is to shift to the end which is "more populated"
+*        Furthermore, decide whether to use DQDS for the computation of
+*        the eigenvalue approximations at the end of SLARRE or bisection.
+*        dqds is chosen if all eigenvalues are desired or the number of
+*        eigenvalues to be computed is large compared to the blocksize.
+         IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+*           If all the eigenvalues have to be computed, we use dqd
+            USEDQD = .TRUE.
+*           INDL is the local index of the first eigenvalue to compute
+            INDL = 1
+            INDU = IN
+*           MB =  number of eigenvalues to compute
+            MB = IN
+            WEND = WBEGIN + MB - 1
+*           Define 1/4 and 3/4 points of the spectrum
+            S1 = ISLEFT + FOURTH * SPDIAM
+            S2 = ISRGHT - FOURTH * SPDIAM
+         ELSE
+*           SLARRD has computed IBLOCK and INDEXW for each eigenvalue
+*           approximation.
+*           choose sigma
+            IF( USEDQD ) THEN
+               S1 = ISLEFT + FOURTH * SPDIAM
+               S2 = ISRGHT - FOURTH * SPDIAM
+            ELSE
+               TMP = MIN(ISRGHT,VU) -  MAX(ISLEFT,VL)
+               S1 =  MAX(ISLEFT,VL) + FOURTH * TMP
+               S2 =  MIN(ISRGHT,VU) - FOURTH * TMP
+            ENDIF
+         ENDIF
+
+*        Compute the negcount at the 1/4 and 3/4 points
+         IF(MB.GT.1) THEN
+            CALL SLARRC( 'T', IN, S1, S2, D(IBEGIN),
+     $                    E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
+         ENDIF
+
+         IF(MB.EQ.1) THEN
+            SIGMA = GL
+            SGNDEF = ONE
+         ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
+            IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+               SIGMA = MAX(ISLEFT,GL)
+            ELSEIF( USEDQD ) THEN
+*              use Gerschgorin bound as shift to get pos def matrix
+*              for dqds
+               SIGMA = ISLEFT
+            ELSE
+*              use approximation of the first desired eigenvalue of the
+*              block as shift
+               SIGMA = MAX(ISLEFT,VL)
+            ENDIF
+            SGNDEF = ONE
+         ELSE
+            IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+               SIGMA = MIN(ISRGHT,GU)
+            ELSEIF( USEDQD ) THEN
+*              use Gerschgorin bound as shift to get neg def matrix
+*              for dqds
+               SIGMA = ISRGHT
+            ELSE
+*              use approximation of the first desired eigenvalue of the
+*              block as shift
+               SIGMA = MIN(ISRGHT,VU)
+            ENDIF
+            SGNDEF = -ONE
+         ENDIF
+
+
+*        An initial SIGMA has been chosen that will be used for computing
+*        T - SIGMA I = L D L^T
+*        Define the increment TAU of the shift in case the initial shift
+*        needs to be refined to obtain a factorization with not too much
+*        element growth.
+         IF( USEDQD ) THEN
+*           The initial SIGMA was to the outer end of the spectrum
+*           the matrix is definite and we need not retreat.
+            TAU = SPDIAM*EPS*N + TWO*PIVMIN
+         ELSE
+            IF(MB.GT.1) THEN
+               CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
+               AVGAP = ABS(CLWDTH / REAL(WEND-WBEGIN))
+               IF( SGNDEF.EQ.ONE ) THEN
+                  TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
+                  TAU = MAX(TAU,WERR(WBEGIN))
+               ELSE
+                  TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
+                  TAU = MAX(TAU,WERR(WEND))
+               ENDIF
+            ELSE
+               TAU = WERR(WBEGIN)
+            ENDIF
+         ENDIF
+*
+         DO 80 IDUM = 1, MAXTRY
+*           Compute L D L^T factorization of tridiagonal matrix T - sigma I.
+*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
+*           pivots in WORK(2*IN+1:3*IN)
+            DPIVOT = D( IBEGIN ) - SIGMA
+            WORK( 1 ) = DPIVOT
+            DMAX = ABS( WORK(1) )
+            J = IBEGIN
+            DO 70 I = 1, IN - 1
+               WORK( 2*IN+I ) = ONE / WORK( I )
+               TMP = E( J )*WORK( 2*IN+I )
+               WORK( IN+I ) = TMP
+               DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
+               WORK( I+1 ) = DPIVOT
+               DMAX = MAX( DMAX, ABS(DPIVOT) )
+               J = J + 1
+ 70         CONTINUE
+*           check for element growth
+            IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
+               NOREP = .TRUE.
+            ELSE
+               NOREP = .FALSE.
+            ENDIF
+            IF( USEDQD .AND. .NOT.NOREP ) THEN
+*              Ensure the definiteness of the representation
+*              All entries of D (of L D L^T) must have the same sign
+               DO 71 I = 1, IN
+                  TMP = SGNDEF*WORK( I )
+                  IF( TMP.LT.ZERO ) NOREP = .TRUE.
+ 71            CONTINUE
+            ENDIF
+            IF(NOREP) THEN
+*              Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
+*              shift which makes the matrix definite. So we should end up
+*              here really only in the case of IRANGE = VALRNG or INDRNG.
+               IF( IDUM.EQ.MAXTRY-1 ) THEN
+                  IF( SGNDEF.EQ.ONE ) THEN
+*                    The fudged Gerschgorin shift should succeed
+                     SIGMA =
+     $                    GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
+                  ELSE
+                     SIGMA =
+     $                    GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
+                  END IF
+               ELSE
+                  SIGMA = SIGMA - SGNDEF * TAU
+                  TAU = TWO * TAU
+               END IF
+            ELSE
+*              an initial RRR is found
+               GO TO 83
+            END IF
+ 80      CONTINUE
+*        if the program reaches this point, no base representation could be
+*        found in MAXTRY iterations.
+         INFO = 2
+         RETURN
+
+ 83      CONTINUE
+*        At this point, we have found an initial base representation
+*        T - SIGMA I = L D L^T with not too much element growth.
+*        Store the shift.
+         E( IEND ) = SIGMA
+*        Store D and L.
+         CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
+         CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
+
+
+         IF(MB.GT.1 ) THEN
+*
+*           Perturb each entry of the base representation by a small
+*           (but random) relative amount to overcome difficulties with
+*           glued matrices.
+*
+            DO 122 I = 1, 4
+               ISEED( I ) = 1
+ 122        CONTINUE
+
+            CALL SLARNV(2, ISEED, 2*IN-1, WORK(1))
+            DO 125 I = 1,IN-1
+               D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
+               E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
+ 125        CONTINUE
+            D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
+*
+         ENDIF
+*
+*        Don't update the Gerschgorin intervals because keeping track
+*        of the updates would be too much work in SLARRV.
+*        We update W instead and use it to locate the proper Gerschgorin
+*        intervals.
+
+*        Compute the required eigenvalues of L D L' by bisection or dqds
+         IF ( .NOT.USEDQD ) THEN
+*           If SLARRD has been used, shift the eigenvalue approximations
+*           according to their representation. This is necessary for
+*           a uniform SLARRV since dqds computes eigenvalues of the
+*           shifted representation. In SLARRV, W will always hold the
+*           UNshifted eigenvalue approximation.
+            DO 134 J=WBEGIN,WEND
+               W(J) = W(J) - SIGMA
+               WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134        CONTINUE
+*           call SLARRB to reduce eigenvalue error of the approximations
+*           from SLARRD
+            DO 135 I = IBEGIN, IEND-1
+               WORK( I ) = D( I ) * E( I )**2
+ 135        CONTINUE
+*           use bisection to find EV from INDL to INDU
+            CALL SLARRB(IN, D(IBEGIN), WORK(IBEGIN),
+     $                  INDL, INDU, RTOL1, RTOL2, INDL-1,
+     $                  W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
+     $                  WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
+     $                  IN, IINFO )
+            IF( IINFO .NE. 0 ) THEN
+               INFO = -4
+               RETURN
+            END IF
+*           SLARRB computes all gaps correctly except for the last one
+*           Record distance to VU/GU
+            WGAP( WEND ) = MAX( ZERO,
+     $           ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
+            DO 138 I = INDL, INDU
+               M = M + 1
+               IBLOCK(M) = JBLK
+               INDEXW(M) = I
+ 138        CONTINUE
+         ELSE
+*           Call dqds to get all eigs (and then possibly delete unwanted
+*           eigenvalues).
+*           Note that dqds finds the eigenvalues of the L D L^T representation
+*           of T to high relative accuracy. High relative accuracy
+*           might be lost when the shift of the RRR is subtracted to obtain
+*           the eigenvalues of T. However, T is not guaranteed to define its
+*           eigenvalues to high relative accuracy anyway.
+*           Set RTOL to the order of the tolerance used in SLASQ2
+*           This is an ESTIMATED error, the worst case bound is 4*N*EPS
+*           which is usually too large and requires unnecessary work to be
+*           done by bisection when computing the eigenvectors
+            RTOL = LOG(REAL(IN)) * FOUR * EPS
+            J = IBEGIN
+            DO 140 I = 1, IN - 1
+               WORK( 2*I-1 ) = ABS( D( J ) )
+               WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
+               J = J + 1
+  140       CONTINUE
+            WORK( 2*IN-1 ) = ABS( D( IEND ) )
+            WORK( 2*IN ) = ZERO
+            CALL SLASQ2( IN, WORK, IINFO )
+            IF( IINFO .NE. 0 ) THEN
+*              If IINFO = -5 then an index is part of a tight cluster
+*              and should be changed. The index is in IWORK(1) and the
+*              gap is in WORK(N+1)
+               INFO = -5
+               RETURN
+            ELSE
+*              Test that all eigenvalues are positive as expected
+               DO 149 I = 1, IN
+                  IF( WORK( I ).LT.ZERO ) THEN
+                     INFO = -6
+                     RETURN
+                  ENDIF
+ 149           CONTINUE
+            END IF
+            IF( SGNDEF.GT.ZERO ) THEN
+               DO 150 I = INDL, INDU
+                  M = M + 1
+                  W( M ) = WORK( IN-I+1 )
+                  IBLOCK( M ) = JBLK
+                  INDEXW( M ) = I
+ 150           CONTINUE
+            ELSE
+               DO 160 I = INDL, INDU
+                  M = M + 1
+                  W( M ) = -WORK( I )
+                  IBLOCK( M ) = JBLK
+                  INDEXW( M ) = I
+ 160           CONTINUE
+            END IF
+
+            DO 165 I = M - MB + 1, M
+*              the value of RTOL below should be the tolerance in SLASQ2
+               WERR( I ) = RTOL * ABS( W(I) )
+ 165        CONTINUE
+            DO 166 I = M - MB + 1, M - 1
+*              compute the right gap between the intervals
+               WGAP( I ) = MAX( ZERO,
+     $                          W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 166        CONTINUE
+            WGAP( M ) = MAX( ZERO,
+     $           ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
+         END IF
+*        proceed with next block
+         IBEGIN = IEND + 1
+         WBEGIN = WEND + 1
+ 170  CONTINUE
+*
+
+      RETURN
+*
+*     end of SLARRE
+*
+      END
diff --git a/SRC/slarrf.f b/SRC/slarrf.f
new file mode 100644
index 00000000..529e4e70
--- /dev/null
+++ b/SRC/slarrf.f
@@ -0,0 +1,373 @@
+      SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND,
+     $                   W, WGAP, WERR,
+     $                   SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
+     $                   DPLUS, LPLUS, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+**
+*     .. Scalar Arguments ..
+      INTEGER            CLSTRT, CLEND, INFO, N
+      REAL               CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), DPLUS( * ), L( * ), LD( * ),
+     $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given the initial representation L D L^T and its cluster of close
+*  eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
+*  W( CLEND ), SLARRF finds a new relatively robust representation
+*  L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
+*  eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix (subblock, if the matrix splitted).
+*
+*  D       (input) REAL             array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D.
+*
+*  L       (input) REAL             array, dimension (N-1)
+*          The (N-1) subdiagonal elements of the unit bidiagonal
+*          matrix L.
+*
+*  LD      (input) REAL             array, dimension (N-1)
+*          The (N-1) elements L(i)*D(i).
+*
+*  CLSTRT  (input) INTEGER
+*          The index of the first eigenvalue in the cluster.
+*
+*  CLEND   (input) INTEGER
+*          The index of the last eigenvalue in the cluster.
+*
+*  W       (input) REAL             array, dimension >=  (CLEND-CLSTRT+1)
+*          The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
+*          W( CLSTRT ) through W( CLEND ) form the cluster of relatively
+*          close eigenalues.
+*
+*  WGAP    (input/output) REAL             array, dimension >=  (CLEND-CLSTRT+1)
+*          The separation from the right neighbor eigenvalue in W.
+*
+*  WERR    (input) REAL             array, dimension >=  (CLEND-CLSTRT+1)
+*          WERR contain the semiwidth of the uncertainty
+*          interval of the corresponding eigenvalue APPROXIMATION in W
+*
+*  SPDIAM (input) estimate of the spectral diameter obtained from the
+*          Gerschgorin intervals
+*
+*  CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
+*          Set by the calling routine to protect against shifts too close
+*          to eigenvalues outside the cluster.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence.
+*
+*  SIGMA   (output) REAL            
+*          The shift used to form L(+) D(+) L(+)^T.
+*
+*  DPLUS   (output) REAL             array, dimension (N)
+*          The N diagonal elements of the diagonal matrix D(+).
+*
+*  LPLUS   (output) REAL             array, dimension (N-1)
+*          The first (N-1) elements of LPLUS contain the subdiagonal
+*          elements of the unit bidiagonal matrix L(+).
+*
+*  WORK    (workspace) REAL             array, dimension (2*N)
+*          Workspace.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
+     $                   ZERO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                     FOUR = 4.0E0, QUART = 0.25E0,
+     $                     MAXGROWTH1 = 8.E0,
+     $                     MAXGROWTH2 = 8.E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL   DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
+      INTEGER            I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
+      PARAMETER          ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
+      REAL               AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
+     $                   FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
+     $                   MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
+     $                   RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
+*     ..
+*     .. External Functions ..
+      LOGICAL SISNAN
+      REAL               SLAMCH
+      EXTERNAL           SISNAN, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      FACT = REAL(2**KTRYMAX)
+      EPS = SLAMCH( 'Precision' )
+      SHIFT = 0
+      FORCER = .FALSE.
+
+
+*     Note that we cannot guarantee that for any of the shifts tried,
+*     the factorization has a small or even moderate element growth.
+*     There could be Ritz values at both ends of the cluster and despite
+*     backing off, there are examples where all factorizations tried
+*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE
+*     element growth.
+*     For this reason, we should use PIVMIN in this subroutine so that at
+*     least the L D L^T factorization exists. It can be checked afterwards
+*     whether the element growth caused bad residuals/orthogonality.
+
+*     Decide whether the code should accept the best among all
+*     representations despite large element growth or signal INFO=1
+      NOFAIL = .TRUE.
+*
+
+*     Compute the average gap length of the cluster
+      CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
+      AVGAP = CLWDTH / REAL(CLEND-CLSTRT)
+      MINGAP = MIN(CLGAPL, CLGAPR)
+*     Initial values for shifts to both ends of cluster
+      LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
+      RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
+
+*     Use a small fudge to make sure that we really shift to the outside
+      LSIGMA = LSIGMA - ABS(LSIGMA)* TWO * EPS
+      RSIGMA = RSIGMA + ABS(RSIGMA)* TWO * EPS
+
+*     Compute upper bounds for how much to back off the initial shifts
+      LDMAX = QUART * MINGAP + TWO * PIVMIN
+      RDMAX = QUART * MINGAP + TWO * PIVMIN
+
+      LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
+      RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
+*
+*     Initialize the record of the best representation found
+*
+      S = SLAMCH( 'S' )
+      SMLGROWTH = ONE / S
+      FAIL = REAL(N-1)*MINGAP/(SPDIAM*EPS)
+      FAIL2 = REAL(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
+      BESTSHIFT = LSIGMA
+*
+*     while (KTRY <= KTRYMAX)
+      KTRY = 0
+      GROWTHBOUND = MAXGROWTH1*SPDIAM
+
+ 5    CONTINUE
+      SAWNAN1 = .FALSE.
+      SAWNAN2 = .FALSE.
+*     Ensure that we do not back off too much of the initial shifts
+      LDELTA = MIN(LDMAX,LDELTA)
+      RDELTA = MIN(RDMAX,RDELTA)
+
+*     Compute the element growth when shifting to both ends of the cluster
+*     accept the shift if there is no element growth at one of the two ends
+
+*     Left end
+      S = -LSIGMA
+      DPLUS( 1 ) = D( 1 ) + S
+      IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
+         DPLUS(1) = -PIVMIN
+*        Need to set SAWNAN1 because refined RRR test should not be used
+*        in this case
+         SAWNAN1 = .TRUE.
+      ENDIF
+      MAX1 = ABS( DPLUS( 1 ) )
+      DO 6 I = 1, N - 1
+         LPLUS( I ) = LD( I ) / DPLUS( I )
+         S = S*LPLUS( I )*L( I ) - LSIGMA
+         DPLUS( I+1 ) = D( I+1 ) + S
+         IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
+            DPLUS(I+1) = -PIVMIN
+*           Need to set SAWNAN1 because refined RRR test should not be used
+*           in this case
+            SAWNAN1 = .TRUE.
+         ENDIF
+         MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 6    CONTINUE
+      SAWNAN1 = SAWNAN1 .OR.  SISNAN( MAX1 )
+
+      IF( FORCER .OR.
+     $   (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
+         SIGMA = LSIGMA
+         SHIFT = SLEFT
+         GOTO 100
+      ENDIF
+
+*     Right end
+      S = -RSIGMA
+      WORK( 1 ) = D( 1 ) + S
+      IF(ABS(WORK(1)).LT.PIVMIN) THEN
+         WORK(1) = -PIVMIN
+*        Need to set SAWNAN2 because refined RRR test should not be used
+*        in this case
+         SAWNAN2 = .TRUE.
+      ENDIF
+      MAX2 = ABS( WORK( 1 ) )
+      DO 7 I = 1, N - 1
+         WORK( N+I ) = LD( I ) / WORK( I )
+         S = S*WORK( N+I )*L( I ) - RSIGMA
+         WORK( I+1 ) = D( I+1 ) + S
+         IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
+            WORK(I+1) = -PIVMIN
+*           Need to set SAWNAN2 because refined RRR test should not be used
+*           in this case
+            SAWNAN2 = .TRUE.
+         ENDIF
+         MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
+ 7    CONTINUE
+      SAWNAN2 = SAWNAN2 .OR.  SISNAN( MAX2 )
+
+      IF( FORCER .OR.
+     $   (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
+         SIGMA = RSIGMA
+         SHIFT = SRIGHT
+         GOTO 100
+      ENDIF
+*     If we are at this point, both shifts led to too much element growth
+
+*     Record the better of the two shifts (provided it didn't lead to NaN)
+      IF(SAWNAN1.AND.SAWNAN2) THEN
+*        both MAX1 and MAX2 are NaN
+         GOTO 50
+      ELSE
+         IF( .NOT.SAWNAN1 ) THEN
+            INDX = 1
+            IF(MAX1.LE.SMLGROWTH) THEN
+               SMLGROWTH = MAX1
+               BESTSHIFT = LSIGMA
+            ENDIF
+         ENDIF
+         IF( .NOT.SAWNAN2 ) THEN
+            IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
+            IF(MAX2.LE.SMLGROWTH) THEN
+               SMLGROWTH = MAX2
+               BESTSHIFT = RSIGMA
+            ENDIF
+         ENDIF
+      ENDIF
+
+*     If we are here, both the left and the right shift led to
+*     element growth. If the element growth is moderate, then
+*     we may still accept the representation, if it passes a
+*     refined test for RRR. This test supposes that no NaN occurred.
+*     Moreover, we use the refined RRR test only for isolated clusters.
+      IF((CLWDTH.LT.MINGAP/REAL(128)) .AND.
+     $   (MIN(MAX1,MAX2).LT.FAIL2)
+     $  .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
+         DORRR1 = .TRUE.
+      ELSE
+         DORRR1 = .FALSE.
+      ENDIF
+      TRYRRR1 = .TRUE.
+      IF( TRYRRR1 .AND. DORRR1 ) THEN
+      IF(INDX.EQ.1) THEN
+         TMP = ABS( DPLUS( N ) )
+         ZNM2 = ONE
+         PROD = ONE
+         OLDP = ONE
+         DO 15 I = N-1, 1, -1
+            IF( PROD .LE. EPS ) THEN
+               PROD =
+     $         ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
+            ELSE
+               PROD = PROD*ABS(WORK(N+I))
+            END IF
+            OLDP = PROD
+            ZNM2 = ZNM2 + PROD**2
+            TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
+ 15      CONTINUE
+         RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+         IF (RRR1.LE.MAXGROWTH2) THEN
+            SIGMA = LSIGMA
+            SHIFT = SLEFT
+            GOTO 100
+         ENDIF
+      ELSE IF(INDX.EQ.2) THEN
+         TMP = ABS( WORK( N ) )
+         ZNM2 = ONE
+         PROD = ONE
+         OLDP = ONE
+         DO 16 I = N-1, 1, -1
+            IF( PROD .LE. EPS ) THEN
+               PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
+            ELSE
+               PROD = PROD*ABS(LPLUS(I))
+            END IF
+            OLDP = PROD
+            ZNM2 = ZNM2 + PROD**2
+            TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
+ 16      CONTINUE
+         RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+         IF (RRR2.LE.MAXGROWTH2) THEN
+            SIGMA = RSIGMA
+            SHIFT = SRIGHT
+            GOTO 100
+         ENDIF
+      END IF
+      ENDIF
+
+ 50   CONTINUE
+
+      IF (KTRY.LT.KTRYMAX) THEN
+*        If we are here, both shifts failed also the RRR test.
+*        Back off to the outside
+         LSIGMA = MAX( LSIGMA - LDELTA,
+     $     LSIGMA - LDMAX)
+         RSIGMA = MIN( RSIGMA + RDELTA,
+     $     RSIGMA + RDMAX )
+         LDELTA = TWO * LDELTA
+         RDELTA = TWO * RDELTA
+         KTRY = KTRY + 1
+         GOTO 5
+      ELSE
+*        None of the representations investigated satisfied our
+*        criteria. Take the best one we found.
+         IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
+            LSIGMA = BESTSHIFT
+            RSIGMA = BESTSHIFT
+            FORCER = .TRUE.
+            GOTO 5
+         ELSE
+            INFO = 1
+            RETURN
+         ENDIF
+      END IF
+
+ 100  CONTINUE
+      IF (SHIFT.EQ.SLEFT) THEN
+      ELSEIF (SHIFT.EQ.SRIGHT) THEN
+*        store new L and D back into DPLUS, LPLUS
+         CALL SCOPY( N, WORK, 1, DPLUS, 1 )
+         CALL SCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
+      ENDIF
+
+      RETURN
+*
+*     End of SLARRF
+*
+      END
diff --git a/SRC/slarrj.f b/SRC/slarrj.f
new file mode 100644
index 00000000..48fda3a3
--- /dev/null
+++ b/SRC/slarrj.f
@@ -0,0 +1,280 @@
+      SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST,
+     $                   RTOL, OFFSET, W, WERR, WORK, IWORK,
+     $                   PIVMIN, SPDIAM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IFIRST, ILAST, INFO, N, OFFSET
+      REAL               PIVMIN, RTOL, SPDIAM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E2( * ), W( * ),
+     $                   WERR( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given the initial eigenvalue approximations of T, SLARRJ
+*  does  bisection to refine the eigenvalues of T,
+*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+*  guesses for these eigenvalues are input in W, the corresponding estimate
+*  of the error in these guesses in WERR. During bisection, intervals
+*  [left, right] are maintained by storing their mid-points and
+*  semi-widths in the arrays W and WERR respectively.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.
+*
+*  D       (input) REAL             array, dimension (N)
+*          The N diagonal elements of T.
+*
+*  E2      (input) REAL             array, dimension (N-1)
+*          The Squares of the (N-1) subdiagonal elements of T.
+*
+*  IFIRST  (input) INTEGER
+*          The index of the first eigenvalue to be computed.
+*
+*  ILAST   (input) INTEGER
+*          The index of the last eigenvalue to be computed.
+*
+*  RTOL   (input) REAL            
+*          Tolerance for the convergence of the bisection intervals.
+*          An interval [LEFT,RIGHT] has converged if
+*          RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
+*
+*  OFFSET  (input) INTEGER
+*          Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
+*          through ILAST-OFFSET elements of these arrays are to be used.
+*
+*  W       (input/output) REAL             array, dimension (N)
+*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+*          estimates of the eigenvalues of L D L^T indexed IFIRST through
+*          ILAST.
+*          On output, these estimates are refined.
+*
+*  WERR    (input/output) REAL             array, dimension (N)
+*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+*          the errors in the estimates of the corresponding elements in W.
+*          On output, these errors are refined.
+*
+*  WORK    (workspace) REAL             array, dimension (2*N)
+*          Workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*N)
+*          Workspace.
+*
+*  PIVMIN  (input) DOUBLE PRECISION
+*          The minimum pivot in the Sturm sequence for T.
+*
+*  SPDIAM  (input) DOUBLE PRECISION
+*          The spectral diameter of T.
+*
+*  INFO    (output) INTEGER
+*          Error flag.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, HALF
+      PARAMETER        ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   HALF = 0.5E0 )
+      INTEGER   MAXITR
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
+     $                   OLNINT, P, PREV, SAVI1
+      REAL               DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
+*
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+      MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+*
+*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+*     for an unconverged interval is set to the index of the next unconverged
+*     interval, and is -1 or 0 for a converged interval. Thus a linked
+*     list of unconverged intervals is set up.
+*
+
+      I1 = IFIRST
+      I2 = ILAST
+*     The number of unconverged intervals
+      NINT = 0
+*     The last unconverged interval found
+      PREV = 0
+      DO 75 I = I1, I2
+         K = 2*I
+         II = I - OFFSET
+         LEFT = W( II ) - WERR( II )
+         MID = W(II)
+         RIGHT = W( II ) + WERR( II )
+         WIDTH = RIGHT - MID
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+*        The following test prevents the test of converged intervals
+         IF( WIDTH.LT.RTOL*TMP ) THEN
+*           This interval has already converged and does not need refinement.
+*           (Note that the gaps might change through refining the
+*            eigenvalues, however, they can only get bigger.)
+*           Remove it from the list.
+            IWORK( K-1 ) = -1
+*           Make sure that I1 always points to the first unconverged interval
+            IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
+            IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
+         ELSE
+*           unconverged interval found
+            PREV = I
+*           Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+*
+*           Do while( CNT(LEFT).GT.I-1 )
+*
+            FAC = ONE
+ 20         CONTINUE
+            CNT = 0
+            S = LEFT
+            DPLUS = D( 1 ) - S
+            IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+            DO 30 J = 2, N
+               DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+               IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 30         CONTINUE
+            IF( CNT.GT.I-1 ) THEN
+               LEFT = LEFT - WERR( II )*FAC
+               FAC = TWO*FAC
+               GO TO 20
+            END IF
+*
+*           Do while( CNT(RIGHT).LT.I )
+*
+            FAC = ONE
+ 50         CONTINUE
+            CNT = 0
+            S = RIGHT
+            DPLUS = D( 1 ) - S
+            IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+            DO 60 J = 2, N
+               DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+               IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 60         CONTINUE
+            IF( CNT.LT.I ) THEN
+               RIGHT = RIGHT + WERR( II )*FAC
+               FAC = TWO*FAC
+               GO TO 50
+            END IF
+            NINT = NINT + 1
+            IWORK( K-1 ) = I + 1
+            IWORK( K ) = CNT
+         END IF
+         WORK( K-1 ) = LEFT
+         WORK( K ) = RIGHT
+ 75   CONTINUE
+
+
+      SAVI1 = I1
+*
+*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+*     and while (ITER.LT.MAXITR)
+*
+      ITER = 0
+ 80   CONTINUE
+      PREV = I1 - 1
+      I = I1
+      OLNINT = NINT
+
+      DO 100 P = 1, OLNINT
+         K = 2*I
+         II = I - OFFSET
+         NEXT = IWORK( K-1 )
+         LEFT = WORK( K-1 )
+         RIGHT = WORK( K )
+         MID = HALF*( LEFT + RIGHT )
+
+*        semiwidth of interval
+         WIDTH = RIGHT - MID
+         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+         IF( ( WIDTH.LT.RTOL*TMP ) .OR.
+     $      (ITER.EQ.MAXITR) )THEN
+*           reduce number of unconverged intervals
+            NINT = NINT - 1
+*           Mark interval as converged.
+            IWORK( K-1 ) = 0
+            IF( I1.EQ.I ) THEN
+               I1 = NEXT
+            ELSE
+*              Prev holds the last unconverged interval previously examined
+               IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+            END IF
+            I = NEXT
+            GO TO 100
+         END IF
+         PREV = I
+*
+*        Perform one bisection step
+*
+         CNT = 0
+         S = MID
+         DPLUS = D( 1 ) - S
+         IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+         DO 90 J = 2, N
+            DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+            IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 90      CONTINUE
+         IF( CNT.LE.I-1 ) THEN
+            WORK( K-1 ) = MID
+         ELSE
+            WORK( K ) = MID
+         END IF
+         I = NEXT
+
+ 100  CONTINUE
+      ITER = ITER + 1
+*     do another loop if there are still unconverged intervals
+*     However, in the last iteration, all intervals are accepted
+*     since this is the best we can do.
+      IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+*     At this point, all the intervals have converged
+      DO 110 I = SAVI1, ILAST
+         K = 2*I
+         II = I - OFFSET
+*        All intervals marked by '0' have been refined.
+         IF( IWORK( K-1 ).EQ.0 ) THEN
+            W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+            WERR( II ) = WORK( K ) - W( II )
+         END IF
+ 110  CONTINUE
+*
+
+      RETURN
+*
+*     End of SLARRJ
+*
+      END
diff --git a/SRC/slarrk.f b/SRC/slarrk.f
new file mode 100644
index 00000000..3b12e06d
--- /dev/null
+++ b/SRC/slarrk.f
@@ -0,0 +1,166 @@
+      SUBROUTINE SLARRK( N, IW, GL, GU,
+     $                    D, E2, PIVMIN, RELTOL, W, WERR, INFO)
+      IMPLICIT NONE
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER   INFO, IW, N
+      REAL                PIVMIN, RELTOL, GL, GU, W, WERR
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARRK computes one eigenvalue of a symmetric tridiagonal
+*  matrix T to suitable accuracy. This is an auxiliary code to be
+*  called from SSTEMR.
+*
+*  To avoid overflow, the matrix must be scaled so that its
+*  largest element is no greater than overflow**(1/2) *
+*  underflow**(1/4) in absolute value, and for greatest
+*  accuracy, it should not be much smaller than that.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal matrix T.  N >= 0.
+*
+*  IW      (input) INTEGER
+*          The index of the eigenvalues to be returned.
+*
+*  GL      (input) REAL            
+*  GU      (input) REAL            
+*          An upper and a lower bound on the eigenvalue.
+*
+*  D       (input) REAL             array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E2      (input) REAL             array, dimension (N-1)
+*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+*  PIVMIN  (input) REAL            
+*          The minimum pivot allowed in the Sturm sequence for T.
+*
+*  RELTOL  (input) REAL            
+*          The minimum relative width of an interval.  When an interval
+*          is narrower than RELTOL times the larger (in
+*          magnitude) endpoint, then it is considered to be
+*          sufficiently small, i.e., converged.  Note: this should
+*          always be at least radix*machine epsilon.
+*
+*  W       (output) REAL            
+*
+*  WERR    (output) REAL            
+*          The error bound on the corresponding eigenvalue approximation
+*          in W.
+*
+*  INFO    (output) INTEGER
+*          = 0:       Eigenvalue converged
+*          = -1:      Eigenvalue did NOT converge
+*
+*  Internal Parameters
+*  ===================
+*
+*  FUDGE   REAL            , default = 2
+*          A "fudge factor" to widen the Gershgorin intervals.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               FUDGE, HALF, TWO, ZERO
+      PARAMETER          ( HALF = 0.5E0, TWO = 2.0E0,
+     $                     FUDGE = TWO, ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER   I, IT, ITMAX, NEGCNT
+      REAL               ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
+     $                   TMP2, TNORM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL   SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Get machine constants
+      EPS = SLAMCH( 'P' )
+
+      TNORM = MAX( ABS( GL ), ABS( GU ) )
+      RTOLI = RELTOL
+      ATOLI = FUDGE*TWO*PIVMIN
+
+      ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+
+      INFO = -1
+
+      LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+      RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+      IT = 0
+
+ 10   CONTINUE
+*
+*     Check if interval converged or maximum number of iterations reached
+*
+      TMP1 = ABS( RIGHT - LEFT )
+      TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
+      IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
+         INFO = 0
+         GOTO 30
+      ENDIF
+      IF(IT.GT.ITMAX)
+     $   GOTO 30
+
+*
+*     Count number of negative pivots for mid-point
+*
+      IT = IT + 1
+      MID = HALF * (LEFT + RIGHT)
+      NEGCNT = 0
+      TMP1 = D( 1 ) - MID
+      IF( ABS( TMP1 ).LT.PIVMIN )
+     $   TMP1 = -PIVMIN
+      IF( TMP1.LE.ZERO )
+     $   NEGCNT = NEGCNT + 1
+*
+      DO 20 I = 2, N
+         TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
+         IF( ABS( TMP1 ).LT.PIVMIN )
+     $      TMP1 = -PIVMIN
+         IF( TMP1.LE.ZERO )
+     $      NEGCNT = NEGCNT + 1
+ 20   CONTINUE
+
+      IF(NEGCNT.GE.IW) THEN
+         RIGHT = MID
+      ELSE
+         LEFT = MID
+      ENDIF
+      GOTO 10
+
+ 30   CONTINUE
+*
+*     Converged or maximum number of iterations reached
+*
+      W = HALF * (LEFT + RIGHT)
+      WERR = HALF * ABS( RIGHT - LEFT )
+
+      RETURN
+*
+*     End of SLARRK
+*
+      END
diff --git a/SRC/slarrr.f b/SRC/slarrr.f
new file mode 100644
index 00000000..c6e2d20b
--- /dev/null
+++ b/SRC/slarrr.f
@@ -0,0 +1,145 @@
+      SUBROUTINE SLARRR( N, D, E, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N, INFO
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E( * )
+*     ..
+*
+*
+*  Purpose
+*  =======
+*
+*  Perform tests to decide whether the symmetric tridiagonal matrix T
+*  warrants expensive computations which guarantee high relative accuracy
+*  in the eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix. N > 0.
+*
+*  D       (input) REAL             array, dimension (N)
+*          The N diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input/output) REAL             array, dimension (N)
+*          On entry, the first (N-1) entries contain the subdiagonal
+*          elements of the tridiagonal matrix T; E(N) is set to ZERO.
+*
+*  INFO    (output) INTEGER
+*          INFO = 0(default) : the matrix warrants computations preserving
+*                              relative accuracy.
+*          INFO = 1          : the matrix warrants computations guaranteeing
+*                              only absolute accuracy.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, RELCOND
+      PARAMETER          ( ZERO = 0.0E0,
+     $                     RELCOND = 0.999E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      LOGICAL            YESREL
+      REAL               EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
+     $          OFFDIG, OFFDIG2
+
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     As a default, do NOT go for relative-accuracy preserving computations.
+      INFO = 1
+
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      RMIN = SQRT( SMLNUM )
+
+*     Tests for relative accuracy
+*
+*     Test for scaled diagonal dominance
+*     Scale the diagonal entries to one and check whether the sum of the
+*     off-diagonals is less than one
+*
+*     The sdd relative error bounds have a 1/(1- 2*x) factor in them,
+*     x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
+*     accuracy is promised.  In the notation of the code fragment below,
+*     1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
+*     We don't think it is worth going into "sdd mode" unless the relative
+*     condition number is reasonable, not 1/macheps.
+*     The threshold should be compatible with other thresholds used in the
+*     code. We set  OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
+*     to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
+*     instead of the current OFFDIG + OFFDIG2 < 1
+*
+      YESREL = .TRUE.
+      OFFDIG = ZERO
+      TMP = SQRT(ABS(D(1)))
+      IF (TMP.LT.RMIN) YESREL = .FALSE.
+      IF(.NOT.YESREL) GOTO 11
+      DO 10 I = 2, N
+         TMP2 = SQRT(ABS(D(I)))
+         IF (TMP2.LT.RMIN) YESREL = .FALSE.
+         IF(.NOT.YESREL) GOTO 11
+         OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
+         IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
+         IF(.NOT.YESREL) GOTO 11
+         TMP = TMP2
+         OFFDIG = OFFDIG2
+ 10   CONTINUE
+ 11   CONTINUE
+
+      IF( YESREL ) THEN
+         INFO = 0
+         RETURN
+      ELSE
+      ENDIF
+*
+
+*
+*     *** MORE TO BE IMPLEMENTED ***
+*
+
+*
+*     Test if the lower bidiagonal matrix L from T = L D L^T
+*     (zero shift facto) is well conditioned
+*
+
+*
+*     Test if the upper bidiagonal matrix U from T = U D U^T
+*     (zero shift facto) is well conditioned.
+*     In this case, the matrix needs to be flipped and, at the end
+*     of the eigenvector computation, the flip needs to be applied
+*     to the computed eigenvectors (and the support)
+*
+
+*
+      RETURN
+*
+*     END OF SLARRR
+*
+      END
diff --git a/SRC/slarrv.f b/SRC/slarrv.f
new file mode 100644
index 00000000..d93d44e9
--- /dev/null
+++ b/SRC/slarrv.f
@@ -0,0 +1,895 @@
+      SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN,
+     $                   ISPLIT, M, DOL, DOU, MINRGP,
+     $                   RTOL1, RTOL2, W, WERR, WGAP,
+     $                   IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            DOL, DOU, INFO, LDZ, M, N
+      REAL               MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+     $                   ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
+     $                   WGAP( * ), WORK( * )
+      REAL              Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARRV computes the eigenvectors of the tridiagonal matrix
+*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
+*  The input eigenvalues should have been computed by SLARRE.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  VL      (input) REAL            
+*  VU      (input) REAL            
+*          Lower and upper bounds of the interval that contains the desired
+*          eigenvalues. VL < VU. Needed to compute gaps on the left or right
+*          end of the extremal eigenvalues in the desired RANGE.
+*
+*  D       (input/output) REAL             array, dimension (N)
+*          On entry, the N diagonal elements of the diagonal matrix D.
+*          On exit, D may be overwritten.
+*
+*  L       (input/output) REAL             array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the unit
+*          bidiagonal matrix L are in elements 1 to N-1 of L
+*          (if the matrix is not splitted.) At the end of each block
+*          is stored the corresponding shift as given by SLARRE.
+*          On exit, L is overwritten.
+*
+*  PIVMIN  (in) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence.
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*
+*  M       (input) INTEGER
+*          The total number of input eigenvalues.  0 <= M <= N.
+*
+*  DOL     (input) INTEGER
+*  DOU     (input) INTEGER
+*          If the user wants to compute only selected eigenvectors from all
+*          the eigenvalues supplied, he can specify an index range DOL:DOU.
+*          Or else the setting DOL=1, DOU=M should be applied.
+*          Note that DOL and DOU refer to the order in which the eigenvalues
+*          are stored in W.
+*          If the user wants to compute only selected eigenpairs, then
+*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+*          computed eigenvectors. All other columns of Z are set to zero.
+*
+*  MINRGP  (input) REAL            
+*
+*  RTOL1   (input) REAL            
+*  RTOL2   (input) REAL            
+*           Parameters for bisection.
+*           An interval [LEFT,RIGHT] has converged if
+*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+*  W       (input/output) REAL             array, dimension (N)
+*          The first M elements of W contain the APPROXIMATE eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block ( The output array
+*          W from SLARRE is expected here ). Furthermore, they are with
+*          respect to the shift of the corresponding root representation
+*          for their block. On exit, W holds the eigenvalues of the
+*          UNshifted matrix.
+*
+*  WERR    (input/output) REAL             array, dimension (N)
+*          The first M elements contain the semiwidth of the uncertainty
+*          interval of the corresponding eigenvalue in W
+*
+*  WGAP    (input/output) REAL             array, dimension (N)
+*          The separation from the right neighbor eigenvalue in W.
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The indices of the blocks (submatrices) associated with the
+*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+*          W(i) belongs to the first block from the top, =2 if W(i)
+*          belongs to the second block, etc.
+*
+*  INDEXW  (input) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+*  GERS    (input) REAL             array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+*          be computed from the original UNshifted matrix.
+*
+*  Z       (output) REAL             array, dimension (LDZ, max(1,M) )
+*          If INFO = 0, the first M columns of Z contain the
+*          orthonormal eigenvectors of the matrix T
+*          corresponding to the input eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The I-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*I-1 ) through
+*          ISUPPZ( 2*I ).
+*
+*  WORK    (workspace) REAL             array, dimension (12*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (7*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*
+*          > 0:  A problem occured in SLARRV.
+*          < 0:  One of the called subroutines signaled an internal problem.
+*                Needs inspection of the corresponding parameter IINFO
+*                for further information.
+*
+*          =-1:  Problem in SLARRB when refining a child's eigenvalues.
+*          =-2:  Problem in SLARRF when computing the RRR of a child.
+*                When a child is inside a tight cluster, it can be difficult
+*                to find an RRR. A partial remedy from the user's point of
+*                view is to make the parameter MINRGP smaller and recompile.
+*                However, as the orthogonality of the computed vectors is
+*                proportional to 1/MINRGP, the user should be aware that
+*                he might be trading in precision when he decreases MINRGP.
+*          =-3:  Problem in SLARRB when refining a single eigenvalue
+*                after the Rayleigh correction was rejected.
+*          = 5:  The Rayleigh Quotient Iteration failed to converge to
+*                full accuracy in MAXITR steps.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXITR
+      PARAMETER          ( MAXITR = 10 )
+      REAL               ZERO, ONE, TWO, THREE, FOUR, HALF
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
+     $                     TWO = 2.0E0, THREE = 3.0E0,
+     $                     FOUR = 4.0E0, HALF = 0.5E0)
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
+      INTEGER            DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
+     $                   IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
+     $                   INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
+     $                   ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
+     $                   NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
+     $                   NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
+     $                   OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
+     $                   WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
+     $                   ZUSEDW
+      REAL               BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
+     $                   LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
+     $                   RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
+     $                   SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
+*     ..
+*     .. External Functions ..
+      REAL              SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAR1V, SLARRB, SLARRF, SLASET,
+     $                   SSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS, REAL, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*     ..
+
+*     The first N entries of WORK are reserved for the eigenvalues
+      INDLD = N+1
+      INDLLD= 2*N+1
+      INDWRK= 3*N+1
+      MINWSIZE = 12 * N
+
+      DO 5 I= 1,MINWSIZE
+         WORK( I ) = ZERO
+ 5    CONTINUE
+
+*     IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
+*     factorization used to compute the FP vector
+      IINDR = 0
+*     IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
+*     layer and the one above.
+      IINDC1 = N
+      IINDC2 = 2*N
+      IINDWK = 3*N + 1
+
+      MINIWSIZE = 7 * N
+      DO 10 I= 1,MINIWSIZE
+         IWORK( I ) = 0
+ 10   CONTINUE
+
+      ZUSEDL = 1
+      IF(DOL.GT.1) THEN
+*        Set lower bound for use of Z
+         ZUSEDL = DOL-1
+      ENDIF
+      ZUSEDU = M
+      IF(DOU.LT.M) THEN
+*        Set lower bound for use of Z
+         ZUSEDU = DOU+1
+      ENDIF
+*     The width of the part of Z that is used
+      ZUSEDW = ZUSEDU - ZUSEDL + 1
+
+
+      CALL SLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
+     $                    Z(1,ZUSEDL), LDZ )
+
+      EPS = SLAMCH( 'Precision' )
+      RQTOL = TWO * EPS
+*
+*     Set expert flags for standard code.
+      TRYRQC = .TRUE.
+
+      IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+      ELSE
+*        Only selected eigenpairs are computed. Since the other evalues
+*        are not refined by RQ iteration, bisection has to compute to full
+*        accuracy.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ENDIF
+
+*     The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
+*     desired eigenvalues. The support of the nonzero eigenvector
+*     entries is contained in the interval IBEGIN:IEND.
+*     Remark that if k eigenpairs are desired, then the eigenvectors
+*     are stored in k contiguous columns of Z.
+
+*     DONE is the number of eigenvectors already computed
+      DONE = 0
+      IBEGIN = 1
+      WBEGIN = 1
+      DO 170 JBLK = 1, IBLOCK( M )
+         IEND = ISPLIT( JBLK )
+         SIGMA = L( IEND )
+*        Find the eigenvectors of the submatrix indexed IBEGIN
+*        through IEND.
+         WEND = WBEGIN - 1
+ 15      CONTINUE
+         IF( WEND.LT.M ) THEN
+            IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+               WEND = WEND + 1
+               GO TO 15
+            END IF
+         END IF
+         IF( WEND.LT.WBEGIN ) THEN
+            IBEGIN = IEND + 1
+            GO TO 170
+         ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+            GO TO 170
+         END IF
+
+*        Find local spectral diameter of the block
+         GL = GERS( 2*IBEGIN-1 )
+         GU = GERS( 2*IBEGIN )
+         DO 20 I = IBEGIN+1 , IEND
+            GL = MIN( GERS( 2*I-1 ), GL )
+            GU = MAX( GERS( 2*I ), GU )
+ 20      CONTINUE
+         SPDIAM = GU - GL
+
+*        OLDIEN is the last index of the previous block
+         OLDIEN = IBEGIN - 1
+*        Calculate the size of the current block
+         IN = IEND - IBEGIN + 1
+*        The number of eigenvalues in the current block
+         IM = WEND - WBEGIN + 1
+
+*        This is for a 1x1 block
+         IF( IBEGIN.EQ.IEND ) THEN
+            DONE = DONE+1
+            Z( IBEGIN, WBEGIN ) = ONE
+            ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
+            ISUPPZ( 2*WBEGIN ) = IBEGIN
+            W( WBEGIN ) = W( WBEGIN ) + SIGMA
+            WORK( WBEGIN ) = W( WBEGIN )
+            IBEGIN = IEND + 1
+            WBEGIN = WBEGIN + 1
+            GO TO 170
+         END IF
+
+*        The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
+*        Note that these can be approximations, in this case, the corresp.
+*        entries of WERR give the size of the uncertainty interval.
+*        The eigenvalue approximations will be refined when necessary as
+*        high relative accuracy is required for the computation of the
+*        corresponding eigenvectors.
+         CALL SCOPY( IM, W( WBEGIN ), 1,
+     &                   WORK( WBEGIN ), 1 )
+
+*        We store in W the eigenvalue approximations w.r.t. the original
+*        matrix T.
+         DO 30 I=1,IM
+            W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 30      CONTINUE
+
+
+*        NDEPTH is the current depth of the representation tree
+         NDEPTH = 0
+*        PARITY is either 1 or 0
+         PARITY = 1
+*        NCLUS is the number of clusters for the next level of the
+*        representation tree, we start with NCLUS = 1 for the root
+         NCLUS = 1
+         IWORK( IINDC1+1 ) = 1
+         IWORK( IINDC1+2 ) = IM
+
+*        IDONE is the number of eigenvectors already computed in the current
+*        block
+         IDONE = 0
+*        loop while( IDONE.LT.IM )
+*        generate the representation tree for the current block and
+*        compute the eigenvectors
+   40    CONTINUE
+         IF( IDONE.LT.IM ) THEN
+*           This is a crude protection against infinitely deep trees
+            IF( NDEPTH.GT.M ) THEN
+               INFO = -2
+               RETURN
+            ENDIF
+*           breadth first processing of the current level of the representation
+*           tree: OLDNCL = number of clusters on current level
+            OLDNCL = NCLUS
+*           reset NCLUS to count the number of child clusters
+            NCLUS = 0
+*
+            PARITY = 1 - PARITY
+            IF( PARITY.EQ.0 ) THEN
+               OLDCLS = IINDC1
+               NEWCLS = IINDC2
+            ELSE
+               OLDCLS = IINDC2
+               NEWCLS = IINDC1
+            END IF
+*           Process the clusters on the current level
+            DO 150 I = 1, OLDNCL
+               J = OLDCLS + 2*I
+*              OLDFST, OLDLST = first, last index of current cluster.
+*                               cluster indices start with 1 and are relative
+*                               to WBEGIN when accessing W, WGAP, WERR, Z
+               OLDFST = IWORK( J-1 )
+               OLDLST = IWORK( J )
+               IF( NDEPTH.GT.0 ) THEN
+*                 Retrieve relatively robust representation (RRR) of cluster
+*                 that has been computed at the previous level
+*                 The RRR is stored in Z and overwritten once the eigenvectors
+*                 have been computed or when the cluster is refined
+
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Get representation from location of the leftmost evalue
+*                    of the cluster
+                     J = WBEGIN + OLDFST - 1
+                  ELSE
+                     IF(WBEGIN+OLDFST-1.LT.DOL) THEN
+*                       Get representation from the left end of Z array
+                        J = DOL - 1
+                     ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
+*                       Get representation from the right end of Z array
+                        J = DOU
+                     ELSE
+                        J = WBEGIN + OLDFST - 1
+                     ENDIF
+                  ENDIF
+                  CALL SCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
+                  CALL SCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
+     $               1 )
+                  SIGMA = Z( IEND, J+1 )
+
+*                 Set the corresponding entries in Z to zero
+                  CALL SLASET( 'Full', IN, 2, ZERO, ZERO,
+     $                         Z( IBEGIN, J), LDZ )
+               END IF
+
+*              Compute DL and DLL of current RRR
+               DO 50 J = IBEGIN, IEND-1
+                  TMP = D( J )*L( J )
+                  WORK( INDLD-1+J ) = TMP
+                  WORK( INDLLD-1+J ) = TMP*L( J )
+   50          CONTINUE
+
+               IF( NDEPTH.GT.0 ) THEN
+*                 P and Q are index of the first and last eigenvalue to compute
+*                 within the current block
+                  P = INDEXW( WBEGIN-1+OLDFST )
+                  Q = INDEXW( WBEGIN-1+OLDLST )
+*                 Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
+*                 thru' Q-OFFSET elements of these arrays are to be used.
+C                  OFFSET = P-OLDFST
+                  OFFSET = INDEXW( WBEGIN ) - 1
+*                 perform limited bisection (if necessary) to get approximate
+*                 eigenvalues to the precision needed.
+                  CALL SLARRB( IN, D( IBEGIN ),
+     $                         WORK(INDLLD+IBEGIN-1),
+     $                         P, Q, RTOL1, RTOL2, OFFSET,
+     $                         WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+     $                         WORK( INDWRK ), IWORK( IINDWK ),
+     $                         PIVMIN, SPDIAM, IN, IINFO )
+                  IF( IINFO.NE.0 ) THEN
+                     INFO = -1
+                     RETURN
+                  ENDIF
+*                 We also recompute the extremal gaps. W holds all eigenvalues
+*                 of the unshifted matrix and must be used for computation
+*                 of WGAP, the entries of WORK might stem from RRRs with
+*                 different shifts. The gaps from WBEGIN-1+OLDFST to
+*                 WBEGIN-1+OLDLST are correctly computed in SLARRB.
+*                 However, we only allow the gaps to become greater since
+*                 this is what should happen when we decrease WERR
+                  IF( OLDFST.GT.1) THEN
+                     WGAP( WBEGIN+OLDFST-2 ) =
+     $             MAX(WGAP(WBEGIN+OLDFST-2),
+     $                 W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
+     $                 - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
+                  ENDIF
+                  IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
+                     WGAP( WBEGIN+OLDLST-1 ) =
+     $               MAX(WGAP(WBEGIN+OLDLST-1),
+     $                   W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
+     $                   - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
+                  ENDIF
+*                 Each time the eigenvalues in WORK get refined, we store
+*                 the newly found approximation with all shifts applied in W
+                  DO 53 J=OLDFST,OLDLST
+                     W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
+ 53               CONTINUE
+               END IF
+
+*              Process the current node.
+               NEWFST = OLDFST
+               DO 140 J = OLDFST, OLDLST
+                  IF( J.EQ.OLDLST ) THEN
+*                    we are at the right end of the cluster, this is also the
+*                    boundary of the child cluster
+                     NEWLST = J
+                  ELSE IF ( WGAP( WBEGIN + J -1).GE.
+     $                    MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+*                    the right relative gap is big enough, the child cluster
+*                    (NEWFST,..,NEWLST) is well separated from the following
+                     NEWLST = J
+                   ELSE
+*                    inside a child cluster, the relative gap is not
+*                    big enough.
+                     GOTO 140
+                  END IF
+
+*                 Compute size of child cluster found
+                  NEWSIZ = NEWLST - NEWFST + 1
+
+*                 NEWFTT is the place in Z where the new RRR or the computed
+*                 eigenvector is to be stored
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Store representation at location of the leftmost evalue
+*                    of the cluster
+                     NEWFTT = WBEGIN + NEWFST - 1
+                  ELSE
+                     IF(WBEGIN+NEWFST-1.LT.DOL) THEN
+*                       Store representation at the left end of Z array
+                        NEWFTT = DOL - 1
+                     ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
+*                       Store representation at the right end of Z array
+                        NEWFTT = DOU
+                     ELSE
+                        NEWFTT = WBEGIN + NEWFST - 1
+                     ENDIF
+                  ENDIF
+
+                  IF( NEWSIZ.GT.1) THEN
+*
+*                    Current child is not a singleton but a cluster.
+*                    Compute and store new representation of child.
+*
+*
+*                    Compute left and right cluster gap.
+*
+*                    LGAP and RGAP are not computed from WORK because
+*                    the eigenvalue approximations may stem from RRRs
+*                    different shifts. However, W hold all eigenvalues
+*                    of the unshifted matrix. Still, the entries in WGAP
+*                    have to be computed from WORK since the entries
+*                    in W might be of the same order so that gaps are not
+*                    exhibited correctly for very close eigenvalues.
+                     IF( NEWFST.EQ.1 ) THEN
+                        LGAP = MAX( ZERO,
+     $                       W(WBEGIN)-WERR(WBEGIN) - VL )
+                    ELSE
+                        LGAP = WGAP( WBEGIN+NEWFST-2 )
+                     ENDIF
+                     RGAP = WGAP( WBEGIN+NEWLST-1 )
+*
+*                    Compute left- and rightmost eigenvalue of child
+*                    to high precision in order to shift as close
+*                    as possible and obtain as large relative gaps
+*                    as possible
+*
+                     DO 55 K =1,2
+                        IF(K.EQ.1) THEN
+                           P = INDEXW( WBEGIN-1+NEWFST )
+                        ELSE
+                           P = INDEXW( WBEGIN-1+NEWLST )
+                        ENDIF
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL SLARRB( IN, D(IBEGIN),
+     $                       WORK( INDLLD+IBEGIN-1 ),P,P,
+     $                       RQTOL, RQTOL, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       IN, IINFO )
+ 55                  CONTINUE
+*
+                     IF((WBEGIN+NEWLST-1.LT.DOL).OR.
+     $                  (WBEGIN+NEWFST-1.GT.DOU)) THEN
+*                       if the cluster contains no desired eigenvalues
+*                       skip the computation of that branch of the rep. tree
+*
+*                       We could skip before the refinement of the extremal
+*                       eigenvalues of the child, but then the representation
+*                       tree could be different from the one when nothing is
+*                       skipped. For this reason we skip at this place.
+                        IDONE = IDONE + NEWLST - NEWFST + 1
+                        GOTO 139
+                     ENDIF
+*
+*                    Compute RRR of child cluster.
+*                    Note that the new RRR is stored in Z
+*
+C                    SLARRF needs LWORK = 2*N
+                     CALL SLARRF( IN, D( IBEGIN ), L( IBEGIN ),
+     $                         WORK(INDLD+IBEGIN-1),
+     $                         NEWFST, NEWLST, WORK(WBEGIN),
+     $                         WGAP(WBEGIN), WERR(WBEGIN),
+     $                         SPDIAM, LGAP, RGAP, PIVMIN, TAU,
+     $                         Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
+     $                         WORK( INDWRK ), IINFO )
+                     IF( IINFO.EQ.0 ) THEN
+*                       a new RRR for the cluster was found by SLARRF
+*                       update shift and store it
+                        SSIGMA = SIGMA + TAU
+                        Z( IEND, NEWFTT+1 ) = SSIGMA
+*                       WORK() are the midpoints and WERR() the semi-width
+*                       Note that the entries in W are unchanged.
+                        DO 116 K = NEWFST, NEWLST
+                           FUDGE =
+     $                          THREE*EPS*ABS(WORK(WBEGIN+K-1))
+                           WORK( WBEGIN + K - 1 ) =
+     $                          WORK( WBEGIN + K - 1) - TAU
+                           FUDGE = FUDGE +
+     $                          FOUR*EPS*ABS(WORK(WBEGIN+K-1))
+*                          Fudge errors
+                           WERR( WBEGIN + K - 1 ) =
+     $                          WERR( WBEGIN + K - 1 ) + FUDGE
+*                          Gaps are not fudged. Provided that WERR is small
+*                          when eigenvalues are close, a zero gap indicates
+*                          that a new representation is needed for resolving
+*                          the cluster. A fudge could lead to a wrong decision
+*                          of judging eigenvalues 'separated' which in
+*                          reality are not. This could have a negative impact
+*                          on the orthogonality of the computed eigenvectors.
+ 116                    CONTINUE
+
+                        NCLUS = NCLUS + 1
+                        K = NEWCLS + 2*NCLUS
+                        IWORK( K-1 ) = NEWFST
+                        IWORK( K ) = NEWLST
+                     ELSE
+                        INFO = -2
+                        RETURN
+                     ENDIF
+                  ELSE
+*
+*                    Compute eigenvector of singleton
+*
+                     ITER = 0
+*
+                     TOL = FOUR * LOG(REAL(IN)) * EPS
+*
+                     K = NEWFST
+                     WINDEX = WBEGIN + K - 1
+                     WINDMN = MAX(WINDEX - 1,1)
+                     WINDPL = MIN(WINDEX + 1,M)
+                     LAMBDA = WORK( WINDEX )
+                     DONE = DONE + 1
+*                    Check if eigenvector computation is to be skipped
+                     IF((WINDEX.LT.DOL).OR.
+     $                  (WINDEX.GT.DOU)) THEN
+                        ESKIP = .TRUE.
+                        GOTO 125
+                     ELSE
+                        ESKIP = .FALSE.
+                     ENDIF
+                     LEFT = WORK( WINDEX ) - WERR( WINDEX )
+                     RIGHT = WORK( WINDEX ) + WERR( WINDEX )
+                     INDEIG = INDEXW( WINDEX )
+*                    Note that since we compute the eigenpairs for a child,
+*                    all eigenvalue approximations are w.r.t the same shift.
+*                    In this case, the entries in WORK should be used for
+*                    computing the gaps since they exhibit even very small
+*                    differences in the eigenvalues, as opposed to the
+*                    entries in W which might "look" the same.
+
+                     IF( K .EQ. 1) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VL, the formula
+*                       LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
+*                       can lead to an overestimation of the left gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small left gap.
+                        LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        LGAP = WGAP(WINDMN)
+                     ENDIF
+                     IF( K .EQ. IM) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VU, the formula
+*                       can lead to an overestimation of the right gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small right gap.
+                        RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        RGAP = WGAP(WINDEX)
+                     ENDIF
+                     GAP = MIN( LGAP, RGAP )
+                     IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
+*                       The eigenvector support can become wrong
+*                       because significant entries could be cut off due to a
+*                       large GAPTOL parameter in LAR1V. Prevent this.
+                        GAPTOL = ZERO
+                     ELSE
+                        GAPTOL = GAP * EPS
+                     ENDIF
+                     ISUPMN = IN
+                     ISUPMX = 1
+*                    Update WGAP so that it holds the minimum gap
+*                    to the left or the right. This is crucial in the
+*                    case where bisection is used to ensure that the
+*                    eigenvalue is refined up to the required precision.
+*                    The correct value is restored afterwards.
+                     SAVGAP = WGAP(WINDEX)
+                     WGAP(WINDEX) = GAP
+*                    We want to use the Rayleigh Quotient Correction
+*                    as often as possible since it converges quadratically
+*                    when we are close enough to the desired eigenvalue.
+*                    However, the Rayleigh Quotient can have the wrong sign
+*                    and lead us away from the desired eigenvalue. In this
+*                    case, the best we can do is to use bisection.
+                     USEDBS = .FALSE.
+                     USEDRQ = .FALSE.
+*                    Bisection is initially turned off unless it is forced
+                     NEEDBS =  .NOT.TRYRQC
+ 120                 CONTINUE
+*                    Check if bisection should be used to refine eigenvalue
+                     IF(NEEDBS) THEN
+*                       Take the bisection as new iterate
+                        USEDBS = .TRUE.
+                        ITMP1 = IWORK( IINDR+WINDEX )
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL SLARRB( IN, D(IBEGIN),
+     $                       WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+     $                       ZERO, TWO*EPS, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       ITMP1, IINFO )
+                        IF( IINFO.NE.0 ) THEN
+                           INFO = -3
+                           RETURN
+                        ENDIF
+                        LAMBDA = WORK( WINDEX )
+*                       Reset twist index from inaccurate LAMBDA to
+*                       force computation of true MINGMA
+                        IWORK( IINDR+WINDEX ) = 0
+                     ENDIF
+*                    Given LAMBDA, compute the eigenvector.
+                     CALL SLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
+     $                    L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+     $                    WORK(INDLLD+IBEGIN-1),
+     $                    PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                    .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                    IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
+     $                    NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                     IF(ITER .EQ. 0) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ELSEIF(RESID.LT.BSTRES) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ENDIF
+                     ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
+                     ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
+                     ITER = ITER + 1
+
+*                    sin alpha <= |resid|/gap
+*                    Note that both the residual and the gap are
+*                    proportional to the matrix, so ||T|| doesn't play
+*                    a role in the quotient
+
+*
+*                    Convergence test for Rayleigh-Quotient iteration
+*                    (omitted when Bisection has been used)
+*
+                     IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
+     $                    RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
+     $                    THEN
+*                       We need to check that the RQCORR update doesn't
+*                       move the eigenvalue away from the desired one and
+*                       towards a neighbor. -> protection with bisection
+                        IF(INDEIG.LE.NEGCNT) THEN
+*                          The wanted eigenvalue lies to the left
+                           SGNDEF = -ONE
+                        ELSE
+*                          The wanted eigenvalue lies to the right
+                           SGNDEF = ONE
+                        ENDIF
+*                       We only use the RQCORR if it improves the
+*                       the iterate reasonably.
+                        IF( ( RQCORR*SGNDEF.GE.ZERO )
+     $                       .AND.( LAMBDA + RQCORR.LE. RIGHT)
+     $                       .AND.( LAMBDA + RQCORR.GE. LEFT)
+     $                       ) THEN
+                           USEDRQ = .TRUE.
+*                          Store new midpoint of bisection interval in WORK
+                           IF(SGNDEF.EQ.ONE) THEN
+*                             The current LAMBDA is on the left of the true
+*                             eigenvalue
+                              LEFT = LAMBDA
+*                             We prefer to assume that the error estimate
+*                             is correct. We could make the interval not
+*                             as a bracket but to be modified if the RQCORR
+*                             chooses to. In this case, the RIGHT side should
+*                             be modified as follows:
+*                              RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
+                           ELSE
+*                             The current LAMBDA is on the right of the true
+*                             eigenvalue
+                              RIGHT = LAMBDA
+*                             See comment about assuming the error estimate is
+*                             correct above.
+*                              LEFT = MIN(LEFT, LAMBDA + RQCORR)
+                           ENDIF
+                           WORK( WINDEX ) =
+     $                       HALF * (RIGHT + LEFT)
+*                          Take RQCORR since it has the correct sign and
+*                          improves the iterate reasonably
+                           LAMBDA = LAMBDA + RQCORR
+*                          Update width of error interval
+                           WERR( WINDEX ) =
+     $                             HALF * (RIGHT-LEFT)
+                        ELSE
+                           NEEDBS = .TRUE.
+                        ENDIF
+                        IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
+*                             The eigenvalue is computed to bisection accuracy
+*                             compute eigenvector and stop
+                           USEDBS = .TRUE.
+                           GOTO 120
+                        ELSEIF( ITER.LT.MAXITR ) THEN
+                           GOTO 120
+                        ELSEIF( ITER.EQ.MAXITR ) THEN
+                           NEEDBS = .TRUE.
+                           GOTO 120
+                        ELSE
+                           INFO = 5
+                           RETURN
+                        END IF
+                     ELSE
+                        STP2II = .FALSE.
+        IF(USEDRQ .AND. USEDBS .AND.
+     $                     BSTRES.LE.RESID) THEN
+                           LAMBDA = BSTW
+                           STP2II = .TRUE.
+                        ENDIF
+                        IF (STP2II) THEN
+*                          improve error angle by second step
+                           CALL SLAR1V( IN, 1, IN, LAMBDA,
+     $                          D( IBEGIN ), L( IBEGIN ),
+     $                          WORK(INDLD+IBEGIN-1),
+     $                          WORK(INDLLD+IBEGIN-1),
+     $                          PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                          .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                          IWORK( IINDR+WINDEX ),
+     $                          ISUPPZ( 2*WINDEX-1 ),
+     $                          NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                        ENDIF
+                        WORK( WINDEX ) = LAMBDA
+                     END IF
+*
+*                    Compute FP-vector support w.r.t. whole matrix
+*
+                     ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
+                     ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
+                     ZFROM = ISUPPZ( 2*WINDEX-1 )
+                     ZTO = ISUPPZ( 2*WINDEX )
+                     ISUPMN = ISUPMN + OLDIEN
+                     ISUPMX = ISUPMX + OLDIEN
+*                    Ensure vector is ok if support in the RQI has changed
+                     IF(ISUPMN.LT.ZFROM) THEN
+                        DO 122 II = ISUPMN,ZFROM-1
+                           Z( II, WINDEX ) = ZERO
+ 122                    CONTINUE
+                     ENDIF
+                     IF(ISUPMX.GT.ZTO) THEN
+                        DO 123 II = ZTO+1,ISUPMX
+                           Z( II, WINDEX ) = ZERO
+ 123                    CONTINUE
+                     ENDIF
+                     CALL SSCAL( ZTO-ZFROM+1, NRMINV,
+     $                       Z( ZFROM, WINDEX ), 1 )
+ 125                 CONTINUE
+*                    Update W
+                     W( WINDEX ) = LAMBDA+SIGMA
+*                    Recompute the gaps on the left and right
+*                    But only allow them to become larger and not
+*                    smaller (which can only happen through "bad"
+*                    cancellation and doesn't reflect the theory
+*                    where the initial gaps are underestimated due
+*                    to WERR being too crude.)
+                     IF(.NOT.ESKIP) THEN
+                        IF( K.GT.1) THEN
+                           WGAP( WINDMN ) = MAX( WGAP(WINDMN),
+     $                          W(WINDEX)-WERR(WINDEX)
+     $                          - W(WINDMN)-WERR(WINDMN) )
+                        ENDIF
+                        IF( WINDEX.LT.WEND ) THEN
+                           WGAP( WINDEX ) = MAX( SAVGAP,
+     $                          W( WINDPL )-WERR( WINDPL )
+     $                          - W( WINDEX )-WERR( WINDEX) )
+                        ENDIF
+                     ENDIF
+                     IDONE = IDONE + 1
+                  ENDIF
+*                 here ends the code for the current child
+*
+ 139              CONTINUE
+*                 Proceed to any remaining child nodes
+                  NEWFST = J + 1
+ 140           CONTINUE
+ 150        CONTINUE
+            NDEPTH = NDEPTH + 1
+            GO TO 40
+         END IF
+         IBEGIN = IEND + 1
+         WBEGIN = WEND + 1
+ 170  CONTINUE
+*
+
+      RETURN
+*
+*     End of SLARRV
+*
+      END
diff --git a/SRC/slartg.f b/SRC/slartg.f
new file mode 100644
index 00000000..4388075b
--- /dev/null
+++ b/SRC/slartg.f
@@ -0,0 +1,145 @@
+      SUBROUTINE SLARTG( 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 ..
+      REAL               CS, F, G, R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARTG 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 SROTG,
+*  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 SBDSQR when
+*        there are zeros on the diagonal).
+*
+*  If F exceeds G in magnitude, CS will be positive.
+*
+*  Arguments
+*  =========
+*
+*  F       (input) REAL
+*          The first component of vector to be rotated.
+*
+*  G       (input) REAL
+*          The second component of vector to be rotated.
+*
+*  CS      (output) REAL
+*          The cosine of the rotation.
+*
+*  SN      (output) REAL
+*          The sine of the rotation.
+*
+*  R       (output) REAL
+*          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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+*     LOGICAL            FIRST
+      INTEGER            COUNT, I
+      REAL               EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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 = SLAMCH( 'S' )
+         EPS = SLAMCH( 'E' )
+         SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( SLAMCH( '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 SLARTG
+*
+      END
diff --git a/SRC/slartv.f b/SRC/slartv.f
new file mode 100644
index 00000000..95d2f810
--- /dev/null
+++ b/SRC/slartv.f
@@ -0,0 +1,76 @@
+      SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      REAL               C( * ), S( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARTV applies a vector of real plane rotations to elements of the
+*  real vectors x and y. For i = 1,2,...,n
+*
+*     ( x(i) ) := (  c(i)  s(i) ) ( x(i) )
+*     ( y(i) )    ( -s(i)  c(i) ) ( y(i) )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCX)
+*          The vector x.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) REAL array,
+*                         dimension (1+(N-1)*INCY)
+*          The vector y.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (input) REAL array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) REAL array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX, IY
+      REAL               XI, YI
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = X( IX )
+         YI = Y( IY )
+         X( IX ) = C( IC )*XI + S( IC )*YI
+         Y( IY ) = C( IC )*YI - S( IC )*XI
+         IX = IX + INCX
+         IY = IY + INCY
+         IC = IC + INCC
+   10 CONTINUE
+      RETURN
+*
+*     End of SLARTV
+*
+      END
diff --git a/SRC/slaruv.f b/SRC/slaruv.f
new file mode 100644
index 00000000..cf505ee2
--- /dev/null
+++ b/SRC/slaruv.f
@@ -0,0 +1,387 @@
+      SUBROUTINE SLARUV( ISEED, N, X )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISEED( 4 )
+      REAL               X( N )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARUV returns a vector of n random real numbers from a uniform (0,1)
+*  distribution (n <= 128).
+*
+*  This is an auxiliary routine called by SLARNV and CLARNV.
+*
+*  Arguments
+*  =========
+*
+*  ISEED   (input/output) INTEGER array, dimension (4)
+*          On entry, the seed of the random number generator; the array
+*          elements must be between 0 and 4095, and ISEED(4) must be
+*          odd.
+*          On exit, the seed is updated.
+*
+*  N       (input) INTEGER
+*          The number of random numbers to be generated. N <= 128.
+*
+*  X       (output) REAL array, dimension (N)
+*          The generated random numbers.
+*
+*  Further Details
+*  ===============
+*
+*  This routine uses a multiplicative congruential method with modulus
+*  2**48 and multiplier 33952834046453 (see G.S.Fishman,
+*  'Multiplicative congruential random number generators with modulus
+*  2**b: an exhaustive analysis for b = 32 and a partial analysis for
+*  b = 48', Math. Comp. 189, pp 331-344, 1990).
+*
+*  48-bit integers are stored in 4 integer array elements with 12 bits
+*  per element. Hence the routine is portable across machines with
+*  integers of 32 bits or more.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      INTEGER            LV, IPW2
+      REAL               R
+      PARAMETER          ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
+*     ..
+*     .. Local Arrays ..
+      INTEGER            MM( LV, 4 )
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN, MOD, REAL
+*     ..
+*     .. Data statements ..
+      DATA               ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
+     $                   2549 /
+      DATA               ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
+     $                   1145 /
+      DATA               ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
+     $                   2253 /
+      DATA               ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
+     $                   305 /
+      DATA               ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
+     $                   3301 /
+      DATA               ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
+     $                   1065 /
+      DATA               ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
+     $                   3133 /
+      DATA               ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
+     $                   2913 /
+      DATA               ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
+     $                   3285 /
+      DATA               ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
+     $                   1241 /
+      DATA               ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
+     $                   1197 /
+      DATA               ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
+     $                   3729 /
+      DATA               ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
+     $                   2501 /
+      DATA               ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
+     $                   1673 /
+      DATA               ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
+     $                   541 /
+      DATA               ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
+     $                   2753 /
+      DATA               ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
+     $                   949 /
+      DATA               ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
+     $                   2361 /
+      DATA               ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
+     $                   1165 /
+      DATA               ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
+     $                   4081 /
+      DATA               ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
+     $                   2725 /
+      DATA               ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
+     $                   3305 /
+      DATA               ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
+     $                   3069 /
+      DATA               ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
+     $                   3617 /
+      DATA               ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
+     $                   3733 /
+      DATA               ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
+     $                   409 /
+      DATA               ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
+     $                   2157 /
+      DATA               ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
+     $                   1361 /
+      DATA               ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
+     $                   3973 /
+      DATA               ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
+     $                   1865 /
+      DATA               ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
+     $                   2525 /
+      DATA               ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
+     $                   1409 /
+      DATA               ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
+     $                   3445 /
+      DATA               ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
+     $                   3577 /
+      DATA               ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
+     $                   77 /
+      DATA               ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
+     $                   3761 /
+      DATA               ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
+     $                   2149 /
+      DATA               ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
+     $                   1449 /
+      DATA               ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
+     $                   3005 /
+      DATA               ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
+     $                   225 /
+      DATA               ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
+     $                   85 /
+      DATA               ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
+     $                   3673 /
+      DATA               ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
+     $                   3117 /
+      DATA               ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
+     $                   3089 /
+      DATA               ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
+     $                   1349 /
+      DATA               ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
+     $                   2057 /
+      DATA               ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
+     $                   413 /
+      DATA               ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
+     $                   65 /
+      DATA               ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
+     $                   1845 /
+      DATA               ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
+     $                   697 /
+      DATA               ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
+     $                   3085 /
+      DATA               ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
+     $                   3441 /
+      DATA               ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
+     $                   1573 /
+      DATA               ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
+     $                   3689 /
+      DATA               ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
+     $                   2941 /
+      DATA               ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
+     $                   929 /
+      DATA               ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
+     $                   533 /
+      DATA               ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
+     $                   2841 /
+      DATA               ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
+     $                   4077 /
+      DATA               ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
+     $                   721 /
+      DATA               ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
+     $                   2821 /
+      DATA               ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
+     $                   2249 /
+      DATA               ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
+     $                   2397 /
+      DATA               ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
+     $                   2817 /
+      DATA               ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
+     $                   245 /
+      DATA               ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
+     $                   1913 /
+      DATA               ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
+     $                   1997 /
+      DATA               ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
+     $                   3121 /
+      DATA               ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
+     $                   997 /
+      DATA               ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
+     $                   1833 /
+      DATA               ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
+     $                   2877 /
+      DATA               ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
+     $                   1633 /
+      DATA               ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
+     $                   981 /
+      DATA               ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
+     $                   2009 /
+      DATA               ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
+     $                   941 /
+      DATA               ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
+     $                   2449 /
+      DATA               ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
+     $                   197 /
+      DATA               ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
+     $                   2441 /
+      DATA               ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
+     $                   285 /
+      DATA               ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
+     $                   1473 /
+      DATA               ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
+     $                   2741 /
+      DATA               ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
+     $                   3129 /
+      DATA               ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
+     $                   909 /
+      DATA               ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
+     $                   2801 /
+      DATA               ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
+     $                   421 /
+      DATA               ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
+     $                   4073 /
+      DATA               ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
+     $                   2813 /
+      DATA               ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
+     $                   2337 /
+      DATA               ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
+     $                   1429 /
+      DATA               ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
+     $                   1177 /
+      DATA               ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
+     $                   1901 /
+      DATA               ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
+     $                   81 /
+      DATA               ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
+     $                   1669 /
+      DATA               ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
+     $                   2633 /
+      DATA               ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
+     $                   2269 /
+      DATA               ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
+     $                   129 /
+      DATA               ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
+     $                   1141 /
+      DATA               ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
+     $                   249 /
+      DATA               ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
+     $                   3917 /
+      DATA               ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
+     $                   2481 /
+      DATA               ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
+     $                   3941 /
+      DATA               ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
+     $                   2217 /
+      DATA               ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
+     $                   2749 /
+      DATA               ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
+     $                   3041 /
+      DATA               ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
+     $                   1877 /
+      DATA               ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
+     $                   345 /
+      DATA               ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
+     $                   2861 /
+      DATA               ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
+     $                   1809 /
+      DATA               ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
+     $                   3141 /
+      DATA               ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
+     $                   2825 /
+      DATA               ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
+     $                   157 /
+      DATA               ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
+     $                   2881 /
+      DATA               ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
+     $                   3637 /
+      DATA               ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
+     $                   1465 /
+      DATA               ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
+     $                   2829 /
+      DATA               ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
+     $                   2161 /
+      DATA               ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
+     $                   3365 /
+      DATA               ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
+     $                   361 /
+      DATA               ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
+     $                   2685 /
+      DATA               ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
+     $                   3745 /
+      DATA               ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
+     $                   2325 /
+      DATA               ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
+     $                   3609 /
+      DATA               ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
+     $                   3821 /
+      DATA               ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
+     $                   3537 /
+      DATA               ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
+     $                   517 /
+      DATA               ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
+     $                   3017 /
+      DATA               ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
+     $                   2141 /
+      DATA               ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
+     $                   1537 /
+*     ..
+*     .. Executable Statements ..
+*
+      I1 = ISEED( 1 )
+      I2 = ISEED( 2 )
+      I3 = ISEED( 3 )
+      I4 = ISEED( 4 )
+*
+      DO 10 I = 1, MIN( N, LV )
+*
+  20     CONTINUE
+*
+*        Multiply the seed by i-th power of the multiplier modulo 2**48
+*
+         IT4 = I4*MM( I, 4 )
+         IT3 = IT4 / IPW2
+         IT4 = IT4 - IPW2*IT3
+         IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
+         IT2 = IT3 / IPW2
+         IT3 = IT3 - IPW2*IT2
+         IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
+         IT1 = IT2 / IPW2
+         IT2 = IT2 - IPW2*IT1
+         IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
+     $         I4*MM( I, 1 )
+         IT1 = MOD( IT1, IPW2 )
+*
+*        Convert 48-bit integer to a real number in the interval (0,1)
+*
+         X( I ) = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R*
+     $            REAL( IT4 ) ) ) )
+*         
+         IF (X( I ).EQ.1.0) THEN
+*           If a real number has n bits of precision, and the first
+*           n bits of the 48-bit integer above happen to be all 1 (which
+*           will occur about once every 2**n calls), then X( I ) will
+*           be rounded to exactly 1.0. In IEEE single precision arithmetic,
+*           this will happen relatively often since n = 24.
+*           Since X( I ) is not supposed to return exactly 0.0 or 1.0,
+*           the statistically correct thing to do in this situation is
+*           simply to iterate again.
+*           N.B. the case X( I ) = 0.0 should not be possible.	
+            I1 = I1 + 2
+            I2 = I2 + 2
+            I3 = I3 + 2
+            I4 = I4 + 2
+            GOTO 20
+         END IF
+*
+   10 CONTINUE
+*
+*     Return final value of seed
+*
+      ISEED( 1 ) = IT1
+      ISEED( 2 ) = IT2
+      ISEED( 3 ) = IT3
+      ISEED( 4 ) = IT4
+      RETURN
+*
+*     End of SLARUV
+*
+      END
diff --git a/SRC/slarz.f b/SRC/slarz.f
new file mode 100644
index 00000000..1c7d948e
--- /dev/null
+++ b/SRC/slarz.f
@@ -0,0 +1,152 @@
+      SUBROUTINE SLARZ( 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
+      REAL               TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARZ 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 STZRZF.
+*
+*  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) REAL array, dimension (1+(L-1)*abs(INCV))
+*          The vector v in the representation of H as returned by
+*          STZRZF. V is not used if TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) REAL
+*          The value tau in the representation of H.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SGER
+*     ..
+*     .. 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 SCOPY( N, C, LDC, WORK, 1 )
+*
+*           w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
+*
+            CALL SGEMV( '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 SAXPY( 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 SGER( 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 SCOPY( M, C, 1, WORK, 1 )
+*
+*           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
+*
+            CALL SGEMV( '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 SAXPY( 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 SGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
+     $                 LDC )
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLARZ
+*
+      END
diff --git a/SRC/slarzb.f b/SRC/slarzb.f
new file mode 100644
index 00000000..5d55e753
--- /dev/null
+++ b/SRC/slarzb.f
@@ -0,0 +1,220 @@
+      SUBROUTINE SLARZB( 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 ..
+      REAL               C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARZB 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) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, STRMM, 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( 'SLARZB', -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 SCOPY( 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 SGEMM( '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 STRMM( '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 SGEMM( '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 SCOPY( 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 SGEMM( '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 STRMM( '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 SGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
+     $                  WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLARZB
+*
+      END
diff --git a/SRC/slarzt.f b/SRC/slarzt.f
new file mode 100644
index 00000000..1b29aa30
--- /dev/null
+++ b/SRC/slarzt.f
@@ -0,0 +1,184 @@
+      SUBROUTINE SLARZT( 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 ..
+      REAL               T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLARZT 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) REAL 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, STRMV, 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( 'SLARZT', -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 SGEMV( '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 STRMV( '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 SLARZT
+*
+      END
diff --git a/SRC/slas2.f b/SRC/slas2.f
new file mode 100644
index 00000000..6e3ab07a
--- /dev/null
+++ b/SRC/slas2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE SLAS2( 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 ..
+      REAL               F, G, H, SSMAX, SSMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAS2  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) REAL
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  G       (input) REAL
+*          The (1,2) element of the 2-by-2 matrix.
+*
+*  H       (input) REAL
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  SSMIN   (output) REAL
+*          The smaller singular value.
+*
+*  SSMAX   (output) REAL
+*          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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               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 SLAS2
+*
+      END
diff --git a/SRC/slascl.f b/SRC/slascl.f
new file mode 100644
index 00000000..ee3a4713
--- /dev/null
+++ b/SRC/slascl.f
@@ -0,0 +1,283 @@
+      SUBROUTINE SLASCL( 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
+      REAL               CFROM, CTO
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASCL 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) REAL
+*  CTO     (input) REAL
+*          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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      INTEGER            I, ITYPE, J, K1, K2, K3, K4
+      REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, SISNAN
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH, SISNAN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
+         INFO = -4
+      ELSE IF( SISNAN(CTO) ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      IF( CFROM1.EQ.CFROMC ) THEN
+!        CFROMC is an inf.  Multiply by a correctly signed zero for
+!        finite CTOC, or a NaN if CTOC is infinite.
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+         CTO1 = CTOC
+      ELSE
+         CTO1 = CTOC / BIGNUM
+         IF( CTO1.EQ.CTOC ) THEN
+!           CTOC is either 0 or an inf.  In both cases, CTOC itself
+!           serves as the correct multiplication factor.
+            MUL = CTOC
+            DONE = .TRUE.
+            CFROMC = ONE
+         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+            MUL = SMLNUM
+            DONE = .FALSE.
+            CFROMC = CFROM1
+         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+            MUL = BIGNUM
+            DONE = .FALSE.
+            CTOC = CTO1
+         ELSE
+            MUL = CTOC / CFROMC
+            DONE = .TRUE.
+         END IF
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of SLASCL
+*
+      END
diff --git a/SRC/slasd0.f b/SRC/slasd0.f
new file mode 100644
index 00000000..996d25cf
--- /dev/null
+++ b/SRC/slasd0.f
@@ -0,0 +1,228 @@
+      SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
+     $                   WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDU, LDVT, N, SMLSIZ, SQRE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Using a divide and conquer approach, SLASD0 computes the singular
+*  value decomposition (SVD) of a real upper bidiagonal N-by-M
+*  matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
+*  The algorithm computes orthogonal matrices U and VT such that
+*  B = U * S * VT. The singular values S are overwritten on D.
+*
+*  A related subroutine, SLASDA, computes only the singular values,
+*  and optionally, the singular vectors in compact form.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         On entry, the row dimension of the upper bidiagonal matrix.
+*         This is also the dimension of the main diagonal array D.
+*
+*  SQRE   (input) INTEGER
+*         Specifies the column dimension of the bidiagonal matrix.
+*         = 0: The bidiagonal matrix has column dimension M = N;
+*         = 1: The bidiagonal matrix has column dimension M = N+1;
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix.
+*         On exit D, if INFO = 0, contains its singular values.
+*
+*  E      (input) REAL array, dimension (M-1)
+*         Contains the subdiagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  U      (output) REAL array, dimension at least (LDQ, N)
+*         On exit, U contains the left singular vectors.
+*
+*  LDU    (input) INTEGER
+*         On entry, leading dimension of U.
+*
+*  VT     (output) REAL array, dimension at least (LDVT, M)
+*         On exit, VT' contains the right singular vectors.
+*
+*  LDVT   (input) INTEGER
+*         On entry, leading dimension of VT.
+*
+*  SMLSIZ (input) INTEGER
+*         On entry, maximum size of the subproblems at the
+*         bottom of the computation tree.
+*
+*  IWORK  (workspace) INTEGER array, dimension (8*N)
+*
+*  WORK   (workspace) REAL array, dimension (3*M**2+2*M)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
+     $                   J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
+     $                   NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
+      REAL               ALPHA, BETA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASD1, SLASDQ, SLASDT, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -2
+      END IF
+*
+      M = N + SQRE
+*
+      IF( LDU.LT.N ) THEN
+         INFO = -6
+      ELSE IF( LDVT.LT.M ) THEN
+         INFO = -8
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD0', -INFO )
+         RETURN
+      END IF
+*
+*     If the input matrix is too small, call SLASDQ to find the SVD.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
+     $                LDU, WORK, INFO )
+         RETURN
+      END IF
+*
+*     Set up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+      IDXQ = NDIMR + N
+      IWK = IDXQ + N
+      CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     For the nodes on bottom level of the tree, solve
+*     their subproblems by SLASDQ.
+*
+      NDB1 = ( ND+1 ) / 2
+      NCC = 0
+      DO 30 I = NDB1, ND
+*
+*     IC : center row of each node
+*     NL : number of rows of left  subproblem
+*     NR : number of rows of right subproblem
+*     NLF: starting row of the left   subproblem
+*     NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NLP1 = NL + 1
+         NR = IWORK( NDIMR+I1 )
+         NRP1 = NR + 1
+         NLF = IC - NL
+         NRF = IC + 1
+         SQREI = 1
+         CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
+     $                VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
+     $                U( NLF, NLF ), LDU, WORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         ITEMP = IDXQ + NLF - 2
+         DO 10 J = 1, NL
+            IWORK( ITEMP+J ) = J
+   10    CONTINUE
+         IF( I.EQ.ND ) THEN
+            SQREI = SQRE
+         ELSE
+            SQREI = 1
+         END IF
+         NRP1 = NR + SQREI
+         CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
+     $                VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
+     $                U( NRF, NRF ), LDU, WORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         ITEMP = IDXQ + IC
+         DO 20 J = 1, NR
+            IWORK( ITEMP+J-1 ) = J
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Now conquer each subproblem bottom-up.
+*
+      DO 50 LVL = NLVL, 1, -1
+*
+*        Find the first node LF and last node LL on the
+*        current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 40 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
+               SQREI = SQRE
+            ELSE
+               SQREI = 1
+            END IF
+            IDXQC = IDXQ + NLF - 1
+            ALPHA = D( IC )
+            BETA = E( IC )
+            CALL SLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
+     $                   U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
+     $                   IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+   40    CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of SLASD0
+*
+      END
diff --git a/SRC/slasd1.f b/SRC/slasd1.f
new file mode 100644
index 00000000..86cddeeb
--- /dev/null
+++ b/SRC/slasd1.f
@@ -0,0 +1,232 @@
+      SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
+     $                   IDXQ, IWORK, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDU, LDVT, NL, NR, SQRE
+      REAL               ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IDXQ( * ), IWORK( * )
+      REAL               D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
+*  where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.
+*
+*  A related subroutine SLASD7 handles the case in which the singular
+*  values (and the singular vectors in factored form) are desired.
+*
+*  SLASD1 computes the SVD as follows:
+*
+*                ( D1(in)  0    0     0 )
+*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
+*                (   0     0   D2(in) 0 )
+*
+*      = U(out) * ( D(out) 0) * VT(out)
+*
+*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+*  elsewhere; and the entry b is empty if SQRE = 0.
+*
+*  The left singular vectors of the original matrix are stored in U, and
+*  the transpose of the right singular vectors are stored in VT, and the
+*  singular values are in D.  The algorithm consists of three stages:
+*
+*     The first stage consists of deflating the size of the problem
+*     when there are multiple singular values or when there are zeros in
+*     the Z vector.  For each such occurence the dimension of the
+*     secular equation problem is reduced by one.  This stage is
+*     performed by the routine SLASD2.
+*
+*     The second stage consists of calculating the updated
+*     singular values. This is done by finding the square roots of the
+*     roots of the secular equation via the routine SLASD4 (as called
+*     by SLASD3). This routine also calculates the singular vectors of
+*     the current problem.
+*
+*     The final stage consists of computing the updated singular vectors
+*     directly using the updated singular values.  The singular vectors
+*     for the current problem are multiplied with the singular vectors
+*     from the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  D      (input/output) REAL array, dimension (NL+NR+1).
+*         N = NL+NR+1
+*         On entry D(1:NL,1:NL) contains the singular values of the
+*         upper block; and D(NL+2:N) contains the singular values of
+*         the lower block. On exit D(1:N) contains the singular values
+*         of the modified matrix.
+*
+*  ALPHA  (input/output) REAL
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input/output) REAL
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  U      (input/output) REAL array, dimension (LDU,N)
+*         On entry U(1:NL, 1:NL) contains the left singular vectors of
+*         the upper block; U(NL+2:N, NL+2:N) contains the left singular
+*         vectors of the lower block. On exit U contains the left
+*         singular vectors of the bidiagonal matrix.
+*
+*  LDU    (input) INTEGER
+*         The leading dimension of the array U.  LDU >= max( 1, N ).
+*
+*  VT     (input/output) REAL array, dimension (LDVT,M)
+*         where M = N + SQRE.
+*         On entry VT(1:NL+1, 1:NL+1)' contains the right singular
+*         vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
+*         the right singular vectors of the lower block. On exit
+*         VT' contains the right singular vectors of the
+*         bidiagonal matrix.
+*
+*  LDVT   (input) INTEGER
+*         The leading dimension of the array VT.  LDVT >= max( 1, M ).
+*
+*  IDXQ  (output) INTEGER array, dimension (N)
+*         This contains the permutation which will reintegrate the
+*         subproblem just solved back into sorted order, i.e.
+*         D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  WORK   (workspace) REAL array, dimension (3*M**2+2*M)
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+*
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
+     $                   IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
+      REAL               ORGNRM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAMRG, SLASCL, SLASD2, SLASD3, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( NL.LT.1 ) THEN
+         INFO = -1
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD1', -INFO )
+         RETURN
+      END IF
+*
+      N = NL + NR + 1
+      M = N + SQRE
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in SLASD2 and SLASD3.
+*
+      LDU2 = N
+      LDVT2 = M
+*
+      IZ = 1
+      ISIGMA = IZ + M
+      IU2 = ISIGMA + N
+      IVT2 = IU2 + LDU2*N
+      IQ = IVT2 + LDVT2*M
+*
+      IDX = 1
+      IDXC = IDX + N
+      COLTYP = IDXC + N
+      IDXP = COLTYP + N
+*
+*     Scale.
+*
+      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+      D( NL+1 ) = ZERO
+      DO 10 I = 1, N
+         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+            ORGNRM = ABS( D( I ) )
+         END IF
+   10 CONTINUE
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      ALPHA = ALPHA / ORGNRM
+      BETA = BETA / ORGNRM
+*
+*     Deflate singular values.
+*
+      CALL SLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
+     $             VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
+     $             WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
+     $             IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
+*
+*     Solve Secular Equation and update singular vectors.
+*
+      LDQ = K
+      CALL SLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
+     $             U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
+     $             LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
+     $             INFO )
+      IF( INFO.NE.0 ) THEN
+         RETURN
+      END IF
+*
+*     Unscale.
+*
+      CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+*     Prepare the IDXQ sorting permutation.
+*
+      N1 = K
+      N2 = N - K
+      CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+      RETURN
+*
+*     End of SLASD1
+*
+      END
diff --git a/SRC/slasd2.f b/SRC/slasd2.f
new file mode 100644
index 00000000..f7e8048d
--- /dev/null
+++ b/SRC/slasd2.f
@@ -0,0 +1,512 @@
+      SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
+     $                   LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
+     $                   IDXC, IDXQ, COLTYP, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
+      REAL               ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      INTEGER            COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
+     $                   IDXQ( * )
+      REAL               D( * ), DSIGMA( * ), U( LDU, * ),
+     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+     $                   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASD2 merges the two sets of singular values together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  singular values are close together or if there is a tiny entry in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  SLASD2 is called from SLASD1.
+*
+*  Arguments
+*  =========
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has N = NL + NR + 1 rows and
+*         M = N + SQRE >= N columns.
+*
+*  K      (output) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  D      (input/output) REAL array, dimension (N)
+*         On entry D contains the singular values of the two submatrices
+*         to be combined.  On exit D contains the trailing (N-K) updated
+*         singular values (those which were deflated) sorted into
+*         increasing order.
+*
+*  Z      (output) REAL array, dimension (N)
+*         On exit Z contains the updating row vector in the secular
+*         equation.
+*
+*  ALPHA  (input) REAL
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input) REAL
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  U      (input/output) REAL array, dimension (LDU,N)
+*         On entry U contains the left singular vectors of two
+*         submatrices in the two square blocks with corners at (1,1),
+*         (NL, NL), and (NL+2, NL+2), (N,N).
+*         On exit U contains the trailing (N-K) updated left singular
+*         vectors (those which were deflated) in its last N-K columns.
+*
+*  LDU    (input) INTEGER
+*         The leading dimension of the array U.  LDU >= N.
+*
+*  VT     (input/output) REAL array, dimension (LDVT,M)
+*         On entry VT' contains the right singular vectors of two
+*         submatrices in the two square blocks with corners at (1,1),
+*         (NL+1, NL+1), and (NL+2, NL+2), (M,M).
+*         On exit VT' contains the trailing (N-K) updated right singular
+*         vectors (those which were deflated) in its last N-K columns.
+*         In case SQRE =1, the last row of VT spans the right null
+*         space.
+*
+*  LDVT   (input) INTEGER
+*         The leading dimension of the array VT.  LDVT >= M.
+*
+*  DSIGMA (output) REAL array, dimension (N)
+*         Contains a copy of the diagonal elements (K-1 singular values
+*         and one zero) in the secular equation.
+*
+*  U2     (output) REAL array, dimension (LDU2,N)
+*         Contains a copy of the first K-1 left singular vectors which
+*         will be used by SLASD3 in a matrix multiply (SGEMM) to solve
+*         for the new left singular vectors. U2 is arranged into four
+*         blocks. The first block contains a column with 1 at NL+1 and
+*         zero everywhere else; the second block contains non-zero
+*         entries only at and above NL; the third contains non-zero
+*         entries only below NL+1; and the fourth is dense.
+*
+*  LDU2   (input) INTEGER
+*         The leading dimension of the array U2.  LDU2 >= N.
+*
+*  VT2    (output) REAL array, dimension (LDVT2,N)
+*         VT2' contains a copy of the first K right singular vectors
+*         which will be used by SLASD3 in a matrix multiply (SGEMM) to
+*         solve for the new right singular vectors. VT2 is arranged into
+*         three blocks. The first block contains a row that corresponds
+*         to the special 0 diagonal element in SIGMA; the second block
+*         contains non-zeros only at and before NL +1; the third block
+*         contains non-zeros only at and after  NL +2.
+*
+*  LDVT2  (input) INTEGER
+*         The leading dimension of the array VT2.  LDVT2 >= M.
+*
+*  IDXP   (workspace) INTEGER array, dimension (N)
+*         This will contain the permutation used to place deflated
+*         values of D at the end of the array. On output IDXP(2:K)
+*         points to the nondeflated D-values and IDXP(K+1:N)
+*         points to the deflated singular values.
+*
+*  IDX    (workspace) INTEGER array, dimension (N)
+*         This will contain the permutation used to sort the contents of
+*         D into ascending order.
+*
+*  IDXC   (output) INTEGER array, dimension (N)
+*         This will contain the permutation used to arrange the columns
+*         of the deflated U matrix into three groups:  the first group
+*         contains non-zero entries only at and above NL, the second
+*         contains non-zero entries only below NL+2, and the third is
+*         dense.
+*
+*  IDXQ   (input/output) INTEGER array, dimension (N)
+*         This contains the permutation which separately sorts the two
+*         sub-problems in D into ascending order.  Note that entries in
+*         the first hlaf of this permutation must first be moved one
+*         position backward; and entries in the second half
+*         must first have NL+1 added to their values.
+*
+*  COLTYP (workspace/output) INTEGER array, dimension (N)
+*         As workspace, this will contain a label which will indicate
+*         which of the following types a column in the U2 matrix or a
+*         row in the VT2 matrix is:
+*         1 : non-zero in the upper half only
+*         2 : non-zero in the lower half only
+*         3 : dense
+*         4 : deflated
+*
+*         On exit, it is an array of dimension 4, with COLTYP(I) being
+*         the dimension of the I-th type columns.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+     $                   EIGHT = 8.0E+0 )
+*     ..
+*     .. Local Arrays ..
+      INTEGER            CTOT( 4 ), PSM( 4 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
+     $                   N, NLP1, NLP2
+      REAL               C, EPS, HLFTOL, S, TAU, TOL, Z1
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           SLAMCH, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SLAMRG, SLASET, SROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( NL.LT.1 ) THEN
+         INFO = -1
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+         INFO = -3
+      END IF
+*
+      N = NL + NR + 1
+      M = N + SQRE
+*
+      IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDVT.LT.M ) THEN
+         INFO = -12
+      ELSE IF( LDU2.LT.N ) THEN
+         INFO = -15
+      ELSE IF( LDVT2.LT.M ) THEN
+         INFO = -17
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD2', -INFO )
+         RETURN
+      END IF
+*
+      NLP1 = NL + 1
+      NLP2 = NL + 2
+*
+*     Generate the first part of the vector Z; and move the singular
+*     values in the first part of D one position backward.
+*
+      Z1 = ALPHA*VT( NLP1, NLP1 )
+      Z( 1 ) = Z1
+      DO 10 I = NL, 1, -1
+         Z( I+1 ) = ALPHA*VT( I, NLP1 )
+         D( I+1 ) = D( I )
+         IDXQ( I+1 ) = IDXQ( I ) + 1
+   10 CONTINUE
+*
+*     Generate the second part of the vector Z.
+*
+      DO 20 I = NLP2, M
+         Z( I ) = BETA*VT( I, NLP2 )
+   20 CONTINUE
+*
+*     Initialize some reference arrays.
+*
+      DO 30 I = 2, NLP1
+         COLTYP( I ) = 1
+   30 CONTINUE
+      DO 40 I = NLP2, N
+         COLTYP( I ) = 2
+   40 CONTINUE
+*
+*     Sort the singular values into increasing order
+*
+      DO 50 I = NLP2, N
+         IDXQ( I ) = IDXQ( I ) + NLP1
+   50 CONTINUE
+*
+*     DSIGMA, IDXC, IDXC, and the first column of U2
+*     are used as storage space.
+*
+      DO 60 I = 2, N
+         DSIGMA( I ) = D( IDXQ( I ) )
+         U2( I, 1 ) = Z( IDXQ( I ) )
+         IDXC( I ) = COLTYP( IDXQ( I ) )
+   60 CONTINUE
+*
+      CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+      DO 70 I = 2, N
+         IDXI = 1 + IDX( I )
+         D( I ) = DSIGMA( IDXI )
+         Z( I ) = U2( IDXI, 1 )
+         COLTYP( I ) = IDXC( IDXI )
+   70 CONTINUE
+*
+*     Calculate the allowable deflation tolerance
+*
+      EPS = SLAMCH( 'Epsilon' )
+      TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+      TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+*     There are 2 kinds of deflation -- first a value in the z-vector
+*     is small, second two (or more) singular values are very close
+*     together (their difference is small).
+*
+*     If the value in the z-vector is small, we simply permute the
+*     array so that the corresponding singular value is moved to the
+*     end.
+*
+*     If two values in the D-vector are close, we perform a two-sided
+*     rotation designed to make one of the corresponding z-vector
+*     entries zero, and then permute the array so that the deflated
+*     singular value is moved to the end.
+*
+*     If there are multiple singular values then the problem deflates.
+*     Here the number of equal singular values are found.  As each equal
+*     singular value is found, an elementary reflector is computed to
+*     rotate the corresponding singular subspace so that the
+*     corresponding components of Z are zero in this new basis.
+*
+      K = 1
+      K2 = N + 1
+      DO 80 J = 2, N
+         IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            IDXP( K2 ) = J
+            COLTYP( J ) = 4
+            IF( J.EQ.N )
+     $         GO TO 120
+         ELSE
+            JPREV = J
+            GO TO 90
+         END IF
+   80 CONTINUE
+   90 CONTINUE
+      J = JPREV
+  100 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 110
+      IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         IDXP( K2 ) = J
+         COLTYP( J ) = 4
+      ELSE
+*
+*        Check if singular values are close enough to allow deflation.
+*
+         IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            S = Z( JPREV )
+            C = Z( J )
+*
+*           Find sqrt(a**2+b**2) without overflow or
+*           destructive underflow.
+*
+            TAU = SLAPY2( C, S )
+            C = C / TAU
+            S = -S / TAU
+            Z( J ) = TAU
+            Z( JPREV ) = ZERO
+*
+*           Apply back the Givens rotation to the left and right
+*           singular vector matrices.
+*
+            IDXJP = IDXQ( IDX( JPREV )+1 )
+            IDXJ = IDXQ( IDX( J )+1 )
+            IF( IDXJP.LE.NLP1 ) THEN
+               IDXJP = IDXJP - 1
+            END IF
+            IF( IDXJ.LE.NLP1 ) THEN
+               IDXJ = IDXJ - 1
+            END IF
+            CALL SROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
+            CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
+     $                 S )
+            IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
+               COLTYP( J ) = 3
+            END IF
+            COLTYP( JPREV ) = 4
+            K2 = K2 - 1
+            IDXP( K2 ) = JPREV
+            JPREV = J
+         ELSE
+            K = K + 1
+            U2( K, 1 ) = Z( JPREV )
+            DSIGMA( K ) = D( JPREV )
+            IDXP( K ) = JPREV
+            JPREV = J
+         END IF
+      END IF
+      GO TO 100
+  110 CONTINUE
+*
+*     Record the last singular value.
+*
+      K = K + 1
+      U2( K, 1 ) = Z( JPREV )
+      DSIGMA( K ) = D( JPREV )
+      IDXP( K ) = JPREV
+*
+  120 CONTINUE
+*
+*     Count up the total number of the various types of columns, then
+*     form a permutation which positions the four column types into
+*     four groups of uniform structure (although one or more of these
+*     groups may be empty).
+*
+      DO 130 J = 1, 4
+         CTOT( J ) = 0
+  130 CONTINUE
+      DO 140 J = 2, N
+         CT = COLTYP( J )
+         CTOT( CT ) = CTOT( CT ) + 1
+  140 CONTINUE
+*
+*     PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+      PSM( 1 ) = 2
+      PSM( 2 ) = 2 + CTOT( 1 )
+      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+*
+*     Fill out the IDXC array so that the permutation which it induces
+*     will place all type-1 columns first, all type-2 columns next,
+*     then all type-3's, and finally all type-4's, starting from the
+*     second column. This applies similarly to the rows of VT.
+*
+      DO 150 J = 2, N
+         JP = IDXP( J )
+         CT = COLTYP( JP )
+         IDXC( PSM( CT ) ) = J
+         PSM( CT ) = PSM( CT ) + 1
+  150 CONTINUE
+*
+*     Sort the singular values and corresponding singular vectors into
+*     DSIGMA, U2, and VT2 respectively.  The singular values/vectors
+*     which were not deflated go into the first K slots of DSIGMA, U2,
+*     and VT2 respectively, while those which were deflated go into the
+*     last N - K slots, except that the first column/row will be treated
+*     separately.
+*
+      DO 160 J = 2, N
+         JP = IDXP( J )
+         DSIGMA( J ) = D( JP )
+         IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
+         IF( IDXJ.LE.NLP1 ) THEN
+            IDXJ = IDXJ - 1
+         END IF
+         CALL SCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
+         CALL SCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
+  160 CONTINUE
+*
+*     Determine DSIGMA(1), DSIGMA(2) and Z(1)
+*
+      DSIGMA( 1 ) = ZERO
+      HLFTOL = TOL / TWO
+      IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+     $   DSIGMA( 2 ) = HLFTOL
+      IF( M.GT.N ) THEN
+         Z( 1 ) = SLAPY2( Z1, Z( M ) )
+         IF( Z( 1 ).LE.TOL ) THEN
+            C = ONE
+            S = ZERO
+            Z( 1 ) = TOL
+         ELSE
+            C = Z1 / Z( 1 )
+            S = Z( M ) / Z( 1 )
+         END IF
+      ELSE
+         IF( ABS( Z1 ).LE.TOL ) THEN
+            Z( 1 ) = TOL
+         ELSE
+            Z( 1 ) = Z1
+         END IF
+      END IF
+*
+*     Move the rest of the updating row to Z.
+*
+      CALL SCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
+*
+*     Determine the first column of U2, the first row of VT2 and the
+*     last row of VT.
+*
+      CALL SLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
+      U2( NLP1, 1 ) = ONE
+      IF( M.GT.N ) THEN
+         DO 170 I = 1, NLP1
+            VT( M, I ) = -S*VT( NLP1, I )
+            VT2( 1, I ) = C*VT( NLP1, I )
+  170    CONTINUE
+         DO 180 I = NLP2, M
+            VT2( 1, I ) = S*VT( M, I )
+            VT( M, I ) = C*VT( M, I )
+  180    CONTINUE
+      ELSE
+         CALL SCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
+      END IF
+      IF( M.GT.N ) THEN
+         CALL SCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
+      END IF
+*
+*     The deflated singular values and their corresponding vectors go
+*     into the back of D, U, and V respectively.
+*
+      IF( N.GT.K ) THEN
+         CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+         CALL SLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
+     $                LDU )
+         CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
+     $                LDVT )
+      END IF
+*
+*     Copy CTOT into COLTYP for referencing in SLASD3.
+*
+      DO 190 J = 1, 4
+         COLTYP( J ) = CTOT( J )
+  190 CONTINUE
+*
+      RETURN
+*
+*     End of SLASD2
+*
+      END
diff --git a/SRC/slasd3.f b/SRC/slasd3.f
new file mode 100644
index 00000000..77cf6d3f
--- /dev/null
+++ b/SRC/slasd3.f
@@ -0,0 +1,358 @@
+      SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
+     $                   LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
+     $                   SQRE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            CTOT( * ), IDXC( * )
+      REAL               D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
+     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+     $                   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASD3 finds all the square roots of the roots of the secular
+*  equation, as defined by the values in D and Z.  It makes the
+*  appropriate calls to SLASD4 and then updates the singular
+*  vectors by matrix multiplication.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  SLASD3 is called from SLASD1.
+*
+*  Arguments
+*  =========
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has N = NL + NR + 1 rows and
+*         M = N + SQRE >= N columns.
+*
+*  K      (input) INTEGER
+*         The size of the secular equation, 1 =< K = < N.
+*
+*  D      (output) REAL array, dimension(K)
+*         On exit the square roots of the roots of the secular equation,
+*         in ascending order.
+*
+*  Q      (workspace) REAL array,
+*                     dimension at least (LDQ,K).
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= K.
+*
+*  DSIGMA (input/output) REAL array, dimension(K)
+*         The first K elements of this array contain the old roots
+*         of the deflated updating problem.  These are the poles
+*         of the secular equation.
+*
+*  U      (output) REAL array, dimension (LDU, N)
+*         The last N - K columns of this matrix contain the deflated
+*         left singular vectors.
+*
+*  LDU    (input) INTEGER
+*         The leading dimension of the array U.  LDU >= N.
+*
+*  U2     (input) REAL array, dimension (LDU2, N)
+*         The first K columns of this matrix contain the non-deflated
+*         left singular vectors for the split problem.
+*
+*  LDU2   (input) INTEGER
+*         The leading dimension of the array U2.  LDU2 >= N.
+*
+*  VT     (output) REAL array, dimension (LDVT, M)
+*         The last M - K columns of VT' contain the deflated
+*         right singular vectors.
+*
+*  LDVT   (input) INTEGER
+*         The leading dimension of the array VT.  LDVT >= N.
+*
+*  VT2    (input/output) REAL array, dimension (LDVT2, N)
+*         The first K columns of VT2' contain the non-deflated
+*         right singular vectors for the split problem.
+*
+*  LDVT2  (input) INTEGER
+*         The leading dimension of the array VT2.  LDVT2 >= N.
+*
+*  IDXC   (input) INTEGER array, dimension (N)
+*         The permutation used to arrange the columns of U (and rows of
+*         VT) into three groups:  the first group contains non-zero
+*         entries only at and above (or before) NL +1; the second
+*         contains non-zero entries only at and below (or after) NL+2;
+*         and the third is dense. The first column of U and the row of
+*         VT are treated separately, however.
+*
+*         The rows of the singular vectors found by SLASD4
+*         must be likewise permuted before the matrix multiplies can
+*         take place.
+*
+*  CTOT   (input) INTEGER array, dimension (4)
+*         A count of the total number of the various types of columns
+*         in U (or rows in VT), as described in IDXC. The fourth column
+*         type is any column which has been deflated.
+*
+*  Z      (input/output) REAL array, dimension (K)
+*         The first K elements of this array contain the components
+*         of the deflation-adjusted updating row vector.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*         > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0,
+     $                     NEGONE = -1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
+      REAL               RHO, TEMP
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3, SNRM2
+      EXTERNAL           SLAMC3, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, SLACPY, SLASCL, SLASD4, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( NL.LT.1 ) THEN
+         INFO = -1
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+         INFO = -3
+      END IF
+*
+      N = NL + NR + 1
+      M = N + SQRE
+      NLP1 = NL + 1
+      NLP2 = NL + 2
+*
+      IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.K ) THEN
+         INFO = -7
+      ELSE IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDU2.LT.N ) THEN
+         INFO = -12
+      ELSE IF( LDVT.LT.M ) THEN
+         INFO = -14
+      ELSE IF( LDVT2.LT.M ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD3', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.1 ) THEN
+         D( 1 ) = ABS( Z( 1 ) )
+         CALL SCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
+         IF( Z( 1 ).GT.ZERO ) THEN
+            CALL SCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
+         ELSE
+            DO 10 I = 1, N
+               U( I, 1 ) = -U2( I, 1 )
+   10       CONTINUE
+         END IF
+         RETURN
+      END IF
+*
+*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DSIGMA(I) if it is 1; this makes the subsequent
+*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DSIGMA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DSIGMA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DSIGMA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 20 I = 1, K
+         DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+   20 CONTINUE
+*
+*     Keep a copy of Z.
+*
+      CALL SCOPY( K, Z, 1, Q, 1 )
+*
+*     Normalize Z.
+*
+      RHO = SNRM2( K, Z, 1 )
+      CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+      RHO = RHO*RHO
+*
+*     Find the new singular values.
+*
+      DO 30 J = 1, K
+         CALL SLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
+     $                VT( 1, J ), INFO )
+*
+*        If the zero finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+   30 CONTINUE
+*
+*     Compute updated Z.
+*
+      DO 60 I = 1, K
+         Z( I ) = U( I, K )*VT( I, K )
+         DO 40 J = 1, I - 1
+            Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+     $               ( DSIGMA( I )-DSIGMA( J ) ) /
+     $               ( DSIGMA( I )+DSIGMA( J ) ) )
+   40    CONTINUE
+         DO 50 J = I, K - 1
+            Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+     $               ( DSIGMA( I )-DSIGMA( J+1 ) ) /
+     $               ( DSIGMA( I )+DSIGMA( J+1 ) ) )
+   50    CONTINUE
+         Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
+   60 CONTINUE
+*
+*     Compute left singular vectors of the modified diagonal matrix,
+*     and store related information for the right singular vectors.
+*
+      DO 90 I = 1, K
+         VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
+         U( 1, I ) = NEGONE
+         DO 70 J = 2, K
+            VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
+            U( J, I ) = DSIGMA( J )*VT( J, I )
+   70    CONTINUE
+         TEMP = SNRM2( K, U( 1, I ), 1 )
+         Q( 1, I ) = U( 1, I ) / TEMP
+         DO 80 J = 2, K
+            JC = IDXC( J )
+            Q( J, I ) = U( JC, I ) / TEMP
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Update the left singular vector matrix.
+*
+      IF( K.EQ.2 ) THEN
+         CALL SGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
+     $               LDU )
+         GO TO 100
+      END IF
+      IF( CTOT( 1 ).GT.0 ) THEN
+         CALL SGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
+     $               Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+         IF( CTOT( 3 ).GT.0 ) THEN
+            KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+            CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+     $                  LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
+         END IF
+      ELSE IF( CTOT( 3 ).GT.0 ) THEN
+         KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+         CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+     $               LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+      ELSE
+         CALL SLACPY( 'F', NL, K, U2, LDU2, U, LDU )
+      END IF
+      CALL SCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
+      KTEMP = 2 + CTOT( 1 )
+      CTEMP = CTOT( 2 ) + CTOT( 3 )
+      CALL SGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
+     $            Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
+*
+*     Generate the right singular vectors.
+*
+  100 CONTINUE
+      DO 120 I = 1, K
+         TEMP = SNRM2( K, VT( 1, I ), 1 )
+         Q( I, 1 ) = VT( 1, I ) / TEMP
+         DO 110 J = 2, K
+            JC = IDXC( J )
+            Q( I, J ) = VT( JC, I ) / TEMP
+  110    CONTINUE
+  120 CONTINUE
+*
+*     Update the right singular vector matrix.
+*
+      IF( K.EQ.2 ) THEN
+         CALL SGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
+     $               VT, LDVT )
+         RETURN
+      END IF
+      KTEMP = 1 + CTOT( 1 )
+      CALL SGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
+     $            VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
+      KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+      IF( KTEMP.LE.LDVT2 )
+     $   CALL SGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
+     $               LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
+     $               LDVT )
+*
+      KTEMP = CTOT( 1 ) + 1
+      NRP1 = NR + SQRE
+      IF( KTEMP.GT.1 ) THEN
+         DO 130 I = 1, K
+            Q( I, KTEMP ) = Q( I, 1 )
+  130    CONTINUE
+         DO 140 I = NLP2, M
+            VT2( KTEMP, I ) = VT2( 1, I )
+  140    CONTINUE
+      END IF
+      CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
+      CALL SGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
+     $            VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
+*
+      RETURN
+*
+*     End of SLASD3
+*
+      END
diff --git a/SRC/slasd4.f b/SRC/slasd4.f
new file mode 100644
index 00000000..0cd7e428
--- /dev/null
+++ b/SRC/slasd4.f
@@ -0,0 +1,890 @@
+      SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I, INFO, N
+      REAL               RHO, SIGMA
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), DELTA( * ), WORK( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the square root of the I-th updated
+*  eigenvalue of a positive symmetric rank-one modification to
+*  a positive diagonal matrix whose entries are given as the squares
+*  of the corresponding entries in the array d, and that
+*
+*         0 <= D(i) < D(j)  for  i < j
+*
+*  and that RHO > 0. This is arranged by the calling routine, and is
+*  no loss in generality.  The rank-one modified system is thus
+*
+*         diag( D ) * diag( D ) +  RHO *  Z * Z_transpose.
+*
+*  where we assume the Euclidean norm of Z is 1.
+*
+*  The method consists of approximating the rational functions in the
+*  secular equation by simpler interpolating rational functions.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The length of all arrays.
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  1 <= I <= N.
+*
+*  D      (input) REAL array, dimension ( N )
+*         The original eigenvalues.  It is assumed that they are in
+*         order, 0 <= D(I) < D(J)  for I < J.
+*
+*  Z      (input) REAL array, dimension (N)
+*         The components of the updating vector.
+*
+*  DELTA  (output) REAL array, dimension (N)
+*         If N .ne. 1, DELTA contains (D(j) - sigma_I) in its  j-th
+*         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA
+*         contains the information necessary to construct the
+*         (singular) eigenvectors.
+*
+*  RHO    (input) REAL
+*         The scalar in the symmetric updating formula.
+*
+*  SIGMA  (output) REAL
+*         The computed sigma_I, the I-th updated eigenvalue.
+*
+*  WORK   (workspace) REAL array, dimension (N)
+*         If N .ne. 1, WORK contains (D(j) + sigma_I) in its  j-th
+*         component.  If N = 1, then WORK( 1 ) = 1.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit
+*         > 0:  if INFO = 1, the updating process failed.
+*
+*  Internal Parameters
+*  ===================
+*
+*  Logical variable ORGATI (origin-at-i?) is used for distinguishing
+*  whether D(i) or D(i+1) is treated as the origin.
+*
+*            ORGATI = .true.    origin at i
+*            ORGATI = .false.   origin at i+1
+*
+*  Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+*  if we are working with THREE poles!
+*
+*  MAXIT is the maximum number of iterations allowed for each
+*  eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 20 )
+      REAL               ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+     $                   THREE = 3.0E+0, FOUR = 4.0E+0, EIGHT = 8.0E+0,
+     $                   TEN = 10.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ORGATI, SWTCH, SWTCH3
+      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
+      REAL               A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
+     $                   DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
+     $                   ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
+     $                   SG2UB, TAU, TEMP, TEMP1, TEMP2, W
+*     ..
+*     .. Local Arrays ..
+      REAL               DD( 3 ), ZZ( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAED6, SLASD5
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Since this routine is called in an inner loop, we do no argument
+*     checking.
+*
+*     Quick return for N=1 and 2.
+*
+      INFO = 0
+      IF( N.EQ.1 ) THEN
+*
+*        Presumably, I=1 upon entry
+*
+         SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
+         DELTA( 1 ) = ONE
+         WORK( 1 ) = ONE
+         RETURN
+      END IF
+      IF( N.EQ.2 ) THEN
+         CALL SLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
+         RETURN
+      END IF
+*
+*     Compute machine epsilon
+*
+      EPS = SLAMCH( 'Epsilon' )
+      RHOINV = ONE / RHO
+*
+*     The case I = N
+*
+      IF( I.EQ.N ) THEN
+*
+*        Initialize some basic variables
+*
+         II = N - 1
+         NITER = 1
+*
+*        Calculate initial guess
+*
+         TEMP = RHO / TWO
+*
+*        If ||Z||_2 is not one, then TEMP should be set to
+*        RHO * ||Z||_2^2 / TWO
+*
+         TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
+         DO 10 J = 1, N
+            WORK( J ) = D( J ) + D( N ) + TEMP1
+            DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
+   10    CONTINUE
+*
+         PSI = ZERO
+         DO 20 J = 1, N - 2
+            PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
+   20    CONTINUE
+*
+         C = RHOINV + PSI
+         W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
+     $       Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
+*
+         IF( W.LE.ZERO ) THEN
+            TEMP1 = SQRT( D( N )*D( N )+RHO )
+            TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
+     $             ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
+     $             Z( N )*Z( N ) / RHO
+*
+*           The following TAU is to approximate
+*           SIGMA_n^2 - D( N )*D( N )
+*
+            IF( C.LE.TEMP ) THEN
+               TAU = RHO
+            ELSE
+               DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+               A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+               B = Z( N )*Z( N )*DELSQ
+               IF( A.LT.ZERO ) THEN
+                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+               ELSE
+                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+               END IF
+            END IF
+*
+*           It can be proved that
+*               D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
+*
+         ELSE
+            DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+            A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+            B = Z( N )*Z( N )*DELSQ
+*
+*           The following TAU is to approximate
+*           SIGMA_n^2 - D( N )*D( N )
+*
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+            ELSE
+               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+            END IF
+*
+*           It can be proved that
+*           D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
+*
+         END IF
+*
+*        The following ETA is to approximate SIGMA_n - D( N )
+*
+         ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
+*
+         SIGMA = D( N ) + ETA
+         DO 30 J = 1, N
+            DELTA( J ) = ( D( J )-D( I ) ) - ETA
+            WORK( J ) = D( J ) + D( I ) + ETA
+   30    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 40 J = 1, II
+            TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   40    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            GO TO 240
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+         DTNSQ = WORK( N )*DELTA( N )
+         C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+         A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
+         B = DTNSQ*DTNSQ1*W
+         IF( C.LT.ZERO )
+     $      C = ABS( C )
+         IF( C.EQ.ZERO ) THEN
+            ETA = RHO - SIGMA*SIGMA
+         ELSE IF( A.GE.ZERO ) THEN
+            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+         ELSE
+            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GT.ZERO )
+     $      ETA = -W / ( DPSI+DPHI )
+         TEMP = ETA - DTNSQ
+         IF( TEMP.GT.RHO )
+     $      ETA = RHO + DTNSQ
+*
+         TAU = TAU + ETA
+         ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+         DO 50 J = 1, N
+            DELTA( J ) = DELTA( J ) - ETA
+            WORK( J ) = WORK( J ) + ETA
+   50    CONTINUE
+*
+         SIGMA = SIGMA + ETA
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 60 J = 1, II
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+   60    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+         PHI = Z( N )*TEMP
+         DPHI = TEMP*TEMP
+         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $            ABS( TAU )*( DPSI+DPHI )
+*
+         W = RHOINV + PHI + PSI
+*
+*        Main loop to update the values of the array   DELTA
+*
+         ITER = NITER + 1
+*
+         DO 90 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               GO TO 240
+            END IF
+*
+*           Calculate the new step
+*
+            DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+            DTNSQ = WORK( N )*DELTA( N )
+            C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+            A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
+            B = DTNSQ1*DTNSQ*W
+            IF( A.GE.ZERO ) THEN
+               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GT.ZERO )
+     $         ETA = -W / ( DPSI+DPHI )
+            TEMP = ETA - DTNSQ
+            IF( TEMP.LE.ZERO )
+     $         ETA = ETA / TWO
+*
+            TAU = TAU + ETA
+            ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+            DO 70 J = 1, N
+               DELTA( J ) = DELTA( J ) - ETA
+               WORK( J ) = WORK( J ) + ETA
+   70       CONTINUE
+*
+            SIGMA = SIGMA + ETA
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 80 J = 1, II
+               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+   80       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+            PHI = Z( N )*TEMP
+            DPHI = TEMP*TEMP
+            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+     $               ABS( TAU )*( DPSI+DPHI )
+*
+            W = RHOINV + PHI + PSI
+   90    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+         GO TO 240
+*
+*        End for the case I = N
+*
+      ELSE
+*
+*        The case for I < N
+*
+         NITER = 1
+         IP1 = I + 1
+*
+*        Calculate initial guess
+*
+         DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
+         DELSQ2 = DELSQ / TWO
+         TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
+         DO 100 J = 1, N
+            WORK( J ) = D( J ) + D( I ) + TEMP
+            DELTA( J ) = ( D( J )-D( I ) ) - TEMP
+  100    CONTINUE
+*
+         PSI = ZERO
+         DO 110 J = 1, I - 1
+            PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+  110    CONTINUE
+*
+         PHI = ZERO
+         DO 120 J = N, I + 2, -1
+            PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+  120    CONTINUE
+         C = RHOINV + PSI + PHI
+         W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
+     $       Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
+*
+         IF( W.GT.ZERO ) THEN
+*
+*           d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
+*
+*           We choose d(i) as origin.
+*
+            ORGATI = .TRUE.
+            SG2LB = ZERO
+            SG2UB = DELSQ2
+            A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+            B = Z( I )*Z( I )*DELSQ
+            IF( A.GT.ZERO ) THEN
+               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            ELSE
+               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+*
+*           TAU now is an estimation of SIGMA^2 - D( I )^2. The
+*           following, however, is the corresponding estimation of
+*           SIGMA - D( I ).
+*
+            ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
+         ELSE
+*
+*           (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
+*
+*           We choose d(i+1) as origin.
+*
+            ORGATI = .FALSE.
+            SG2LB = -DELSQ2
+            SG2UB = ZERO
+            A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+            B = Z( IP1 )*Z( IP1 )*DELSQ
+            IF( A.LT.ZERO ) THEN
+               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+            ELSE
+               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+            END IF
+*
+*           TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
+*           following, however, is the corresponding estimation of
+*           SIGMA - D( IP1 ).
+*
+            ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
+     $            TAU ) ) )
+         END IF
+*
+         IF( ORGATI ) THEN
+            II = I
+            SIGMA = D( I ) + ETA
+            DO 130 J = 1, N
+               WORK( J ) = D( J ) + D( I ) + ETA
+               DELTA( J ) = ( D( J )-D( I ) ) - ETA
+  130       CONTINUE
+         ELSE
+            II = I + 1
+            SIGMA = D( IP1 ) + ETA
+            DO 140 J = 1, N
+               WORK( J ) = D( J ) + D( IP1 ) + ETA
+               DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
+  140       CONTINUE
+         END IF
+         IIM1 = II - 1
+         IIP1 = II + 1
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 150 J = 1, IIM1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  150    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 160 J = N, IIP1, -1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  160    CONTINUE
+*
+         W = RHOINV + PHI + PSI
+*
+*        W is the value of the secular function with
+*        its ii-th element removed.
+*
+         SWTCH3 = .FALSE.
+         IF( ORGATI ) THEN
+            IF( W.LT.ZERO )
+     $         SWTCH3 = .TRUE.
+         ELSE
+            IF( W.GT.ZERO )
+     $         SWTCH3 = .TRUE.
+         END IF
+         IF( II.EQ.1 .OR. II.EQ.N )
+     $      SWTCH3 = .FALSE.
+*
+         TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = W + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+*        Test for convergence
+*
+         IF( ABS( W ).LE.EPS*ERRETM ) THEN
+            GO TO 240
+         END IF
+*
+         IF( W.LE.ZERO ) THEN
+            SG2LB = MAX( SG2LB, TAU )
+         ELSE
+            SG2UB = MIN( SG2UB, TAU )
+         END IF
+*
+*        Calculate the new step
+*
+         NITER = NITER + 1
+         IF( .NOT.SWTCH3 ) THEN
+            DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+            DTISQ = WORK( I )*DELTA( I )
+            IF( ORGATI ) THEN
+               C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+            ELSE
+               C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+            END IF
+            A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+            B = DTIPSQ*DTISQ*W
+            IF( C.EQ.ZERO ) THEN
+               IF( A.EQ.ZERO ) THEN
+                  IF( ORGATI ) THEN
+                     A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
+                  ELSE
+                     A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
+                  END IF
+               END IF
+               ETA = B / A
+            ELSE IF( A.LE.ZERO ) THEN
+               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+            ELSE
+               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+            END IF
+         ELSE
+*
+*           Interpolation using THREE most relevant poles
+*
+            DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+            DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+            TEMP = RHOINV + PSI + PHI
+            IF( ORGATI ) THEN
+               TEMP1 = Z( IIM1 ) / DTIIM
+               TEMP1 = TEMP1*TEMP1
+               C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
+     $             ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+               IF( DPSI.LT.TEMP1 ) THEN
+                  ZZ( 3 ) = DTIIP*DTIIP*DPHI
+               ELSE
+                  ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+               END IF
+            ELSE
+               TEMP1 = Z( IIP1 ) / DTIIP
+               TEMP1 = TEMP1*TEMP1
+               C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
+     $             ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+               IF( DPHI.LT.TEMP1 ) THEN
+                  ZZ( 1 ) = DTIIM*DTIIM*DPSI
+               ELSE
+                  ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+               END IF
+               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+            END IF
+            ZZ( 2 ) = Z( II )*Z( II )
+            DD( 1 ) = DTIIM
+            DD( 2 ) = DELTA( II )*WORK( II )
+            DD( 3 ) = DTIIP
+            CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+            IF( INFO.NE.0 )
+     $         GO TO 240
+         END IF
+*
+*        Note, eta should be positive if w is negative, and
+*        eta should be negative otherwise. However,
+*        if for some reason caused by roundoff, eta*w > 0,
+*        we simply use one Newton step instead. This way
+*        will guarantee eta*w < 0.
+*
+         IF( W*ETA.GE.ZERO )
+     $      ETA = -W / DW
+         IF( ORGATI ) THEN
+            TEMP1 = WORK( I )*DELTA( I )
+            TEMP = ETA - TEMP1
+         ELSE
+            TEMP1 = WORK( IP1 )*DELTA( IP1 )
+            TEMP = ETA - TEMP1
+         END IF
+         IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+            IF( W.LT.ZERO ) THEN
+               ETA = ( SG2UB-TAU ) / TWO
+            ELSE
+               ETA = ( SG2LB-TAU ) / TWO
+            END IF
+         END IF
+*
+         TAU = TAU + ETA
+         ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+         PREW = W
+*
+         SIGMA = SIGMA + ETA
+         DO 170 J = 1, N
+            WORK( J ) = WORK( J ) + ETA
+            DELTA( J ) = DELTA( J ) - ETA
+  170    CONTINUE
+*
+*        Evaluate PSI and the derivative DPSI
+*
+         DPSI = ZERO
+         PSI = ZERO
+         ERRETM = ZERO
+         DO 180 J = 1, IIM1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PSI = PSI + Z( J )*TEMP
+            DPSI = DPSI + TEMP*TEMP
+            ERRETM = ERRETM + PSI
+  180    CONTINUE
+         ERRETM = ABS( ERRETM )
+*
+*        Evaluate PHI and the derivative DPHI
+*
+         DPHI = ZERO
+         PHI = ZERO
+         DO 190 J = N, IIP1, -1
+            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+            PHI = PHI + Z( J )*TEMP
+            DPHI = DPHI + TEMP*TEMP
+            ERRETM = ERRETM + PHI
+  190    CONTINUE
+*
+         TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+         DW = DPSI + DPHI + TEMP*TEMP
+         TEMP = Z( II )*TEMP
+         W = RHOINV + PHI + PSI + TEMP
+         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $            THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+         IF( W.LE.ZERO ) THEN
+            SG2LB = MAX( SG2LB, TAU )
+         ELSE
+            SG2UB = MIN( SG2UB, TAU )
+         END IF
+*
+         SWTCH = .FALSE.
+         IF( ORGATI ) THEN
+            IF( -W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         ELSE
+            IF( W.GT.ABS( PREW ) / TEN )
+     $         SWTCH = .TRUE.
+         END IF
+*
+*        Main loop to update the values of the array   DELTA and WORK
+*
+         ITER = NITER + 1
+*
+         DO 230 NITER = ITER, MAXIT
+*
+*           Test for convergence
+*
+            IF( ABS( W ).LE.EPS*ERRETM ) THEN
+               GO TO 240
+            END IF
+*
+*           Calculate the new step
+*
+            IF( .NOT.SWTCH3 ) THEN
+               DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+               DTISQ = WORK( I )*DELTA( I )
+               IF( .NOT.SWTCH ) THEN
+                  IF( ORGATI ) THEN
+                     C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+                  ELSE
+                     C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+                  END IF
+               ELSE
+                  TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+                  IF( ORGATI ) THEN
+                     DPSI = DPSI + TEMP*TEMP
+                  ELSE
+                     DPHI = DPHI + TEMP*TEMP
+                  END IF
+                  C = W - DTISQ*DPSI - DTIPSQ*DPHI
+               END IF
+               A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+               B = DTIPSQ*DTISQ*W
+               IF( C.EQ.ZERO ) THEN
+                  IF( A.EQ.ZERO ) THEN
+                     IF( .NOT.SWTCH ) THEN
+                        IF( ORGATI ) THEN
+                           A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
+     $                         ( DPSI+DPHI )
+                        ELSE
+                           A = Z( IP1 )*Z( IP1 ) +
+     $                         DTISQ*DTISQ*( DPSI+DPHI )
+                        END IF
+                     ELSE
+                        A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
+                     END IF
+                  END IF
+                  ETA = B / A
+               ELSE IF( A.LE.ZERO ) THEN
+                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+               ELSE
+                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+               END IF
+            ELSE
+*
+*              Interpolation using THREE most relevant poles
+*
+               DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+               DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+               TEMP = RHOINV + PSI + PHI
+               IF( SWTCH ) THEN
+                  C = TEMP - DTIIM*DPSI - DTIIP*DPHI
+                  ZZ( 1 ) = DTIIM*DTIIM*DPSI
+                  ZZ( 3 ) = DTIIP*DTIIP*DPHI
+               ELSE
+                  IF( ORGATI ) THEN
+                     TEMP1 = Z( IIM1 ) / DTIIM
+                     TEMP1 = TEMP1*TEMP1
+                     TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
+     $                       ( D( IIM1 )+D( IIP1 ) )*TEMP1
+                     C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
+                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+                     IF( DPSI.LT.TEMP1 ) THEN
+                        ZZ( 3 ) = DTIIP*DTIIP*DPHI
+                     ELSE
+                        ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+                     END IF
+                  ELSE
+                     TEMP1 = Z( IIP1 ) / DTIIP
+                     TEMP1 = TEMP1*TEMP1
+                     TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
+     $                       ( D( IIM1 )+D( IIP1 ) )*TEMP1
+                     C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
+                     IF( DPHI.LT.TEMP1 ) THEN
+                        ZZ( 1 ) = DTIIM*DTIIM*DPSI
+                     ELSE
+                        ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+                     END IF
+                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+                  END IF
+               END IF
+               DD( 1 ) = DTIIM
+               DD( 2 ) = DELTA( II )*WORK( II )
+               DD( 3 ) = DTIIP
+               CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 240
+            END IF
+*
+*           Note, eta should be positive if w is negative, and
+*           eta should be negative otherwise. However,
+*           if for some reason caused by roundoff, eta*w > 0,
+*           we simply use one Newton step instead. This way
+*           will guarantee eta*w < 0.
+*
+            IF( W*ETA.GE.ZERO )
+     $         ETA = -W / DW
+            IF( ORGATI ) THEN
+               TEMP1 = WORK( I )*DELTA( I )
+               TEMP = ETA - TEMP1
+            ELSE
+               TEMP1 = WORK( IP1 )*DELTA( IP1 )
+               TEMP = ETA - TEMP1
+            END IF
+            IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+               IF( W.LT.ZERO ) THEN
+                  ETA = ( SG2UB-TAU ) / TWO
+               ELSE
+                  ETA = ( SG2LB-TAU ) / TWO
+               END IF
+            END IF
+*
+            TAU = TAU + ETA
+            ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+            SIGMA = SIGMA + ETA
+            DO 200 J = 1, N
+               WORK( J ) = WORK( J ) + ETA
+               DELTA( J ) = DELTA( J ) - ETA
+  200       CONTINUE
+*
+            PREW = W
+*
+*           Evaluate PSI and the derivative DPSI
+*
+            DPSI = ZERO
+            PSI = ZERO
+            ERRETM = ZERO
+            DO 210 J = 1, IIM1
+               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+               PSI = PSI + Z( J )*TEMP
+               DPSI = DPSI + TEMP*TEMP
+               ERRETM = ERRETM + PSI
+  210       CONTINUE
+            ERRETM = ABS( ERRETM )
+*
+*           Evaluate PHI and the derivative DPHI
+*
+            DPHI = ZERO
+            PHI = ZERO
+            DO 220 J = N, IIP1, -1
+               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+               PHI = PHI + Z( J )*TEMP
+               DPHI = DPHI + TEMP*TEMP
+               ERRETM = ERRETM + PHI
+  220       CONTINUE
+*
+            TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+            DW = DPSI + DPHI + TEMP*TEMP
+            TEMP = Z( II )*TEMP
+            W = RHOINV + PHI + PSI + TEMP
+            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+     $               THREE*ABS( TEMP ) + ABS( TAU )*DW
+            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+     $         SWTCH = .NOT.SWTCH
+*
+            IF( W.LE.ZERO ) THEN
+               SG2LB = MAX( SG2LB, TAU )
+            ELSE
+               SG2UB = MIN( SG2UB, TAU )
+            END IF
+*
+  230    CONTINUE
+*
+*        Return with INFO = 1, NITER = MAXIT and not converged
+*
+         INFO = 1
+*
+      END IF
+*
+  240 CONTINUE
+      RETURN
+*
+*     End of SLASD4
+*
+      END
diff --git a/SRC/slasd5.f b/SRC/slasd5.f
new file mode 100644
index 00000000..4442f2fc
--- /dev/null
+++ b/SRC/slasd5.f
@@ -0,0 +1,163 @@
+      SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I
+      REAL               DSIGMA, RHO
+*     ..
+*     .. Array Arguments ..
+      REAL               D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This subroutine computes the square root of the I-th eigenvalue
+*  of a positive symmetric rank-one modification of a 2-by-2 diagonal
+*  matrix
+*
+*             diag( D ) * diag( D ) +  RHO *  Z * transpose(Z) .
+*
+*  The diagonal entries in the array D are assumed to satisfy
+*
+*             0 <= D(i) < D(j)  for  i < j .
+*
+*  We also assume RHO > 0 and that the Euclidean norm of the vector
+*  Z is one.
+*
+*  Arguments
+*  =========
+*
+*  I      (input) INTEGER
+*         The index of the eigenvalue to be computed.  I = 1 or I = 2.
+*
+*  D      (input) REAL array, dimension (2)
+*         The original eigenvalues.  We assume 0 <= D(1) < D(2).
+*
+*  Z      (input) REAL array, dimension (2)
+*         The components of the updating vector.
+*
+*  DELTA  (output) REAL array, dimension (2)
+*         Contains (D(j) - sigma_I) in its  j-th component.
+*         The vector DELTA contains the information necessary
+*         to construct the eigenvectors.
+*
+*  RHO    (input) REAL
+*         The scalar in the symmetric updating formula.
+*
+*  DSIGMA (output) REAL
+*         The computed sigma_I, the I-th updated eigenvalue.
+*
+*  WORK   (workspace) REAL array, dimension (2)
+*         WORK contains (D(j) + sigma_I) in its  j-th component.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ren-Cang Li, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, THREE, FOUR
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+     $                   THREE = 3.0E+0, FOUR = 4.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      REAL               B, C, DEL, DELSQ, TAU, W
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      DEL = D( 2 ) - D( 1 )
+      DELSQ = DEL*( D( 2 )+D( 1 ) )
+      IF( I.EQ.1 ) THEN
+         W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
+     $       Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
+         IF( W.GT.ZERO ) THEN
+            B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 1 )*Z( 1 )*DELSQ
+*
+*           B > ZERO, always
+*
+*           The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
+*
+            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+*
+*           The following TAU is DSIGMA - D( 1 )
+*
+            TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
+            DSIGMA = D( 1 ) + TAU
+            DELTA( 1 ) = -TAU
+            DELTA( 2 ) = DEL - TAU
+            WORK( 1 ) = TWO*D( 1 ) + TAU
+            WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
+*           DELTA( 1 ) = -Z( 1 ) / TAU
+*           DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+         ELSE
+            B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+            C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+*           The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+            IF( B.GT.ZERO ) THEN
+               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+            ELSE
+               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+            END IF
+*
+*           The following TAU is DSIGMA - D( 2 )
+*
+            TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
+            DSIGMA = D( 2 ) + TAU
+            DELTA( 1 ) = -( DEL+TAU )
+            DELTA( 2 ) = -TAU
+            WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+            WORK( 2 ) = TWO*D( 2 ) + TAU
+*           DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+*           DELTA( 2 ) = -Z( 2 ) / TAU
+         END IF
+*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+*        DELTA( 1 ) = DELTA( 1 ) / TEMP
+*        DELTA( 2 ) = DELTA( 2 ) / TEMP
+      ELSE
+*
+*        Now I=2
+*
+         B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+         C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+*        The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+         IF( B.GT.ZERO ) THEN
+            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+         ELSE
+            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+         END IF
+*
+*        The following TAU is DSIGMA - D( 2 )
+*
+         TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
+         DSIGMA = D( 2 ) + TAU
+         DELTA( 1 ) = -( DEL+TAU )
+         DELTA( 2 ) = -TAU
+         WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+         WORK( 2 ) = TWO*D( 2 ) + TAU
+*        DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+*        DELTA( 2 ) = -Z( 2 ) / TAU
+*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+*        DELTA( 1 ) = DELTA( 1 ) / TEMP
+*        DELTA( 2 ) = DELTA( 2 ) / TEMP
+      END IF
+      RETURN
+*
+*     End of SLASD5
+*
+      END
diff --git a/SRC/slasd6.f b/SRC/slasd6.f
new file mode 100644
index 00000000..c211aae3
--- /dev/null
+++ b/SRC/slasd6.f
@@ -0,0 +1,305 @@
+      SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
+     $                   IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
+     $                   LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+     $                   NR, SQRE
+      REAL               ALPHA, BETA, C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
+     $                   PERM( * )
+      REAL               D( * ), DIFL( * ), DIFR( * ),
+     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
+     $                   VF( * ), VL( * ), WORK( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASD6 computes the SVD of an updated upper bidiagonal matrix B
+*  obtained by merging two smaller ones by appending a row. This
+*  routine is used only for the problem which requires all singular
+*  values and optionally singular vector matrices in factored form.
+*  B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
+*  A related subroutine, SLASD1, handles the case in which all singular
+*  values and singular vectors of the bidiagonal matrix are desired.
+*
+*  SLASD6 computes the SVD as follows:
+*
+*                ( D1(in)  0    0     0 )
+*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
+*                (   0     0   D2(in) 0 )
+*
+*      = U(out) * ( D(out) 0) * VT(out)
+*
+*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+*  elsewhere; and the entry b is empty if SQRE = 0.
+*
+*  The singular values of B can be computed using D1, D2, the first
+*  components of all the right singular vectors of the lower block, and
+*  the last components of all the right singular vectors of the upper
+*  block. These components are stored and updated in VF and VL,
+*  respectively, in SLASD6. Hence U and VT are not explicitly
+*  referenced.
+*
+*  The singular values are stored in D. The algorithm consists of two
+*  stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple singular values or if there is a zero
+*        in the Z vector. For each such occurence the dimension of the
+*        secular equation problem is reduced by one. This stage is
+*        performed by the routine SLASD7.
+*
+*        The second stage consists of calculating the updated
+*        singular values. This is done by finding the roots of the
+*        secular equation via the routine SLASD4 (as called by SLASD8).
+*        This routine also updates VF and VL and computes the distances
+*        between the updated singular values and the old singular
+*        values.
+*
+*  SLASD6 is called from SLASDA.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed in
+*         factored form:
+*         = 0: Compute singular values only.
+*         = 1: Compute singular vectors in factored form as well.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block.  NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block.  NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  D      (input/output) REAL array, dimension (NL+NR+1).
+*         On entry D(1:NL,1:NL) contains the singular values of the
+*         upper block, and D(NL+2:N) contains the singular values
+*         of the lower block. On exit D(1:N) contains the singular
+*         values of the modified matrix.
+*
+*  VF     (input/output) REAL array, dimension (M)
+*         On entry, VF(1:NL+1) contains the first components of all
+*         right singular vectors of the upper block; and VF(NL+2:M)
+*         contains the first components of all right singular vectors
+*         of the lower block. On exit, VF contains the first components
+*         of all right singular vectors of the bidiagonal matrix.
+*
+*  VL     (input/output) REAL array, dimension (M)
+*         On entry, VL(1:NL+1) contains the  last components of all
+*         right singular vectors of the upper block; and VL(NL+2:M)
+*         contains the last components of all right singular vectors of
+*         the lower block. On exit, VL contains the last components of
+*         all right singular vectors of the bidiagonal matrix.
+*
+*  ALPHA  (input/output) REAL
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input/output) REAL
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  IDXQ   (output) INTEGER array, dimension (N)
+*         This contains the permutation which will reintegrate the
+*         subproblem just solved back into sorted order, i.e.
+*         D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  PERM   (output) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) to be applied
+*         to each block. Not referenced if ICOMPQ = 0.
+*
+*  GIVPTR (output) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem. Not referenced if ICOMPQ = 0.
+*
+*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGCOL (input) INTEGER
+*         leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value to be used in the
+*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of GIVNUM and POLES, must be at least N.
+*
+*  POLES  (output) REAL array, dimension ( LDGNUM, 2 )
+*         On exit, POLES(1,*) is an array containing the new singular
+*         values obtained from solving the secular equation, and
+*         POLES(2,*) is an array containing the poles in the secular
+*         equation. Not referenced if ICOMPQ = 0.
+*
+*  DIFL   (output) REAL array, dimension ( N )
+*         On exit, DIFL(I) is the distance between I-th updated
+*         (undeflated) singular value and the I-th (undeflated) old
+*         singular value.
+*
+*  DIFR   (output) REAL array,
+*                  dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
+*                  dimension ( N ) if ICOMPQ = 0.
+*         On exit, DIFR(I, 1) is the distance between I-th updated
+*         (undeflated) singular value and the I+1-th (undeflated) old
+*         singular value.
+*
+*         If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+*         normalizing factors for the right singular vector matrix.
+*
+*         See SLASD8 for details on DIFL and DIFR.
+*
+*  Z      (output) REAL array, dimension ( M )
+*         The first elements of this array contain the components
+*         of the deflation-adjusted updating row vector.
+*
+*  K      (output) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  C      (output) REAL
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (output) REAL
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  WORK   (workspace) REAL array, dimension ( 4 * M )
+*
+*  IWORK  (workspace) INTEGER 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 = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
+     $                   N, N1, N2
+      REAL               ORGNRM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAMRG, SLASCL, SLASD7, SLASD8, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      N = NL + NR + 1
+      M = N + SQRE
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -14
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD6', -INFO )
+         RETURN
+      END IF
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in SLASD7 and SLASD8.
+*
+      ISIGMA = 1
+      IW = ISIGMA + N
+      IVFW = IW + M
+      IVLW = IVFW + M
+*
+      IDX = 1
+      IDXC = IDX + N
+      IDXP = IDXC + N
+*
+*     Scale.
+*
+      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+      D( NL+1 ) = ZERO
+      DO 10 I = 1, N
+         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+            ORGNRM = ABS( D( I ) )
+         END IF
+   10 CONTINUE
+      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      ALPHA = ALPHA / ORGNRM
+      BETA = BETA / ORGNRM
+*
+*     Sort and Deflate singular values.
+*
+      CALL SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
+     $             WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
+     $             WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
+     $             PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
+     $             INFO )
+*
+*     Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
+*
+      CALL SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
+     $             WORK( ISIGMA ), WORK( IW ), INFO )
+*
+*     Save the poles if ICOMPQ = 1.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         CALL SCOPY( K, D, 1, POLES( 1, 1 ), 1 )
+         CALL SCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
+      END IF
+*
+*     Unscale.
+*
+      CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+*     Prepare the IDXQ sorting permutation.
+*
+      N1 = K
+      N2 = N - K
+      CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+      RETURN
+*
+*     End of SLASD6
+*
+      END
diff --git a/SRC/slasd7.f b/SRC/slasd7.f
new file mode 100644
index 00000000..a8e67b34
--- /dev/null
+++ b/SRC/slasd7.f
@@ -0,0 +1,444 @@
+      SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
+     $                   VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
+     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
+     $                   C, S, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+     $                   NR, SQRE
+      REAL               ALPHA, BETA, C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
+     $                   IDXQ( * ), PERM( * )
+      REAL               D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
+     $                   VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
+     $                   ZW( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASD7 merges the two sets of singular values together into a single
+*  sorted set. Then it tries to deflate the size of the problem. There
+*  are two ways in which deflation can occur:  when two or more singular
+*  values are close together or if there is a tiny entry in the Z
+*  vector. For each such occurrence the order of the related
+*  secular equation problem is reduced by one.
+*
+*  SLASD7 is called from SLASD6.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          Specifies whether singular vectors are to be computed
+*          in compact form, as follows:
+*          = 0: Compute singular values only.
+*          = 1: Compute singular vectors of upper
+*               bidiagonal matrix in compact form.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block. NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block. NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has
+*         N = NL + NR + 1 rows and
+*         M = N + SQRE >= N columns.
+*
+*  K      (output) INTEGER
+*         Contains the dimension of the non-deflated matrix, this is
+*         the order of the related secular equation. 1 <= K <=N.
+*
+*  D      (input/output) REAL array, dimension ( N )
+*         On entry D contains the singular values of the two submatrices
+*         to be combined. On exit D contains the trailing (N-K) updated
+*         singular values (those which were deflated) sorted into
+*         increasing order.
+*
+*  Z      (output) REAL array, dimension ( M )
+*         On exit Z contains the updating row vector in the secular
+*         equation.
+*
+*  ZW     (workspace) REAL array, dimension ( M )
+*         Workspace for Z.
+*
+*  VF     (input/output) REAL array, dimension ( M )
+*         On entry, VF(1:NL+1) contains the first components of all
+*         right singular vectors of the upper block; and VF(NL+2:M)
+*         contains the first components of all right singular vectors
+*         of the lower block. On exit, VF contains the first components
+*         of all right singular vectors of the bidiagonal matrix.
+*
+*  VFW    (workspace) REAL array, dimension ( M )
+*         Workspace for VF.
+*
+*  VL     (input/output) REAL array, dimension ( M )
+*         On entry, VL(1:NL+1) contains the  last components of all
+*         right singular vectors of the upper block; and VL(NL+2:M)
+*         contains the last components of all right singular vectors
+*         of the lower block. On exit, VL contains the last components
+*         of all right singular vectors of the bidiagonal matrix.
+*
+*  VLW    (workspace) REAL array, dimension ( M )
+*         Workspace for VL.
+*
+*  ALPHA  (input) REAL
+*         Contains the diagonal element associated with the added row.
+*
+*  BETA   (input) REAL
+*         Contains the off-diagonal element associated with the added
+*         row.
+*
+*  DSIGMA (output) REAL array, dimension ( N )
+*         Contains a copy of the diagonal elements (K-1 singular values
+*         and one zero) in the secular equation.
+*
+*  IDX    (workspace) INTEGER array, dimension ( N )
+*         This will contain the permutation used to sort the contents of
+*         D into ascending order.
+*
+*  IDXP   (workspace) INTEGER array, dimension ( N )
+*         This will contain the permutation used to place deflated
+*         values of D at the end of the array. On output IDXP(2:K)
+*         points to the nondeflated D-values and IDXP(K+1:N)
+*         points to the deflated singular values.
+*
+*  IDXQ   (input) INTEGER array, dimension ( N )
+*         This contains the permutation which separately sorts the two
+*         sub-problems in D into ascending order.  Note that entries in
+*         the first half of this permutation must first be moved one
+*         position backward; and entries in the second half
+*         must first have NL+1 added to their values.
+*
+*  PERM   (output) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) to be applied
+*         to each singular block. Not referenced if ICOMPQ = 0.
+*
+*  GIVPTR (output) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem. Not referenced if ICOMPQ = 0.
+*
+*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGCOL (input) INTEGER
+*         The leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value to be used in the
+*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of GIVNUM, must be at least N.
+*
+*  C      (output) REAL
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (output) REAL
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+     $                   EIGHT = 8.0E+0 )
+*     ..
+*     .. Local Scalars ..
+*
+      INTEGER            I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
+     $                   NLP1, NLP2
+      REAL               EPS, HLFTOL, TAU, TOL, Z1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAMRG, SROT, XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLAPY2
+      EXTERNAL           SLAMCH, SLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      N = NL + NR + 1
+      M = N + SQRE
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -22
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -24
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD7', -INFO )
+         RETURN
+      END IF
+*
+      NLP1 = NL + 1
+      NLP2 = NL + 2
+      IF( ICOMPQ.EQ.1 ) THEN
+         GIVPTR = 0
+      END IF
+*
+*     Generate the first part of the vector Z and move the singular
+*     values in the first part of D one position backward.
+*
+      Z1 = ALPHA*VL( NLP1 )
+      VL( NLP1 ) = ZERO
+      TAU = VF( NLP1 )
+      DO 10 I = NL, 1, -1
+         Z( I+1 ) = ALPHA*VL( I )
+         VL( I ) = ZERO
+         VF( I+1 ) = VF( I )
+         D( I+1 ) = D( I )
+         IDXQ( I+1 ) = IDXQ( I ) + 1
+   10 CONTINUE
+      VF( 1 ) = TAU
+*
+*     Generate the second part of the vector Z.
+*
+      DO 20 I = NLP2, M
+         Z( I ) = BETA*VF( I )
+         VF( I ) = ZERO
+   20 CONTINUE
+*
+*     Sort the singular values into increasing order
+*
+      DO 30 I = NLP2, N
+         IDXQ( I ) = IDXQ( I ) + NLP1
+   30 CONTINUE
+*
+*     DSIGMA, IDXC, IDXC, and ZW are used as storage space.
+*
+      DO 40 I = 2, N
+         DSIGMA( I ) = D( IDXQ( I ) )
+         ZW( I ) = Z( IDXQ( I ) )
+         VFW( I ) = VF( IDXQ( I ) )
+         VLW( I ) = VL( IDXQ( I ) )
+   40 CONTINUE
+*
+      CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+      DO 50 I = 2, N
+         IDXI = 1 + IDX( I )
+         D( I ) = DSIGMA( IDXI )
+         Z( I ) = ZW( IDXI )
+         VF( I ) = VFW( IDXI )
+         VL( I ) = VLW( IDXI )
+   50 CONTINUE
+*
+*     Calculate the allowable deflation tolerence
+*
+      EPS = SLAMCH( 'Epsilon' )
+      TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+      TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+*     There are 2 kinds of deflation -- first a value in the z-vector
+*     is small, second two (or more) singular values are very close
+*     together (their difference is small).
+*
+*     If the value in the z-vector is small, we simply permute the
+*     array so that the corresponding singular value is moved to the
+*     end.
+*
+*     If two values in the D-vector are close, we perform a two-sided
+*     rotation designed to make one of the corresponding z-vector
+*     entries zero, and then permute the array so that the deflated
+*     singular value is moved to the end.
+*
+*     If there are multiple singular values then the problem deflates.
+*     Here the number of equal singular values are found.  As each equal
+*     singular value is found, an elementary reflector is computed to
+*     rotate the corresponding singular subspace so that the
+*     corresponding components of Z are zero in this new basis.
+*
+      K = 1
+      K2 = N + 1
+      DO 60 J = 2, N
+         IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            IDXP( K2 ) = J
+            IF( J.EQ.N )
+     $         GO TO 100
+         ELSE
+            JPREV = J
+            GO TO 70
+         END IF
+   60 CONTINUE
+   70 CONTINUE
+      J = JPREV
+   80 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 90
+      IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         IDXP( K2 ) = J
+      ELSE
+*
+*        Check if singular values are close enough to allow deflation.
+*
+         IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            S = Z( JPREV )
+            C = Z( J )
+*
+*           Find sqrt(a**2+b**2) without overflow or
+*           destructive underflow.
+*
+            TAU = SLAPY2( C, S )
+            Z( J ) = TAU
+            Z( JPREV ) = ZERO
+            C = C / TAU
+            S = -S / TAU
+*
+*           Record the appropriate Givens rotation
+*
+            IF( ICOMPQ.EQ.1 ) THEN
+               GIVPTR = GIVPTR + 1
+               IDXJP = IDXQ( IDX( JPREV )+1 )
+               IDXJ = IDXQ( IDX( J )+1 )
+               IF( IDXJP.LE.NLP1 ) THEN
+                  IDXJP = IDXJP - 1
+               END IF
+               IF( IDXJ.LE.NLP1 ) THEN
+                  IDXJ = IDXJ - 1
+               END IF
+               GIVCOL( GIVPTR, 2 ) = IDXJP
+               GIVCOL( GIVPTR, 1 ) = IDXJ
+               GIVNUM( GIVPTR, 2 ) = C
+               GIVNUM( GIVPTR, 1 ) = S
+            END IF
+            CALL SROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
+            CALL SROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
+            K2 = K2 - 1
+            IDXP( K2 ) = JPREV
+            JPREV = J
+         ELSE
+            K = K + 1
+            ZW( K ) = Z( JPREV )
+            DSIGMA( K ) = D( JPREV )
+            IDXP( K ) = JPREV
+            JPREV = J
+         END IF
+      END IF
+      GO TO 80
+   90 CONTINUE
+*
+*     Record the last singular value.
+*
+      K = K + 1
+      ZW( K ) = Z( JPREV )
+      DSIGMA( K ) = D( JPREV )
+      IDXP( K ) = JPREV
+*
+  100 CONTINUE
+*
+*     Sort the singular values into DSIGMA. The singular values which
+*     were not deflated go into the first K slots of DSIGMA, except
+*     that DSIGMA(1) is treated separately.
+*
+      DO 110 J = 2, N
+         JP = IDXP( J )
+         DSIGMA( J ) = D( JP )
+         VFW( J ) = VF( JP )
+         VLW( J ) = VL( JP )
+  110 CONTINUE
+      IF( ICOMPQ.EQ.1 ) THEN
+         DO 120 J = 2, N
+            JP = IDXP( J )
+            PERM( J ) = IDXQ( IDX( JP )+1 )
+            IF( PERM( J ).LE.NLP1 ) THEN
+               PERM( J ) = PERM( J ) - 1
+            END IF
+  120    CONTINUE
+      END IF
+*
+*     The deflated singular values go back into the last N - K slots of
+*     D.
+*
+      CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+*
+*     Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
+*     VL(M).
+*
+      DSIGMA( 1 ) = ZERO
+      HLFTOL = TOL / TWO
+      IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+     $   DSIGMA( 2 ) = HLFTOL
+      IF( M.GT.N ) THEN
+         Z( 1 ) = SLAPY2( Z1, Z( M ) )
+         IF( Z( 1 ).LE.TOL ) THEN
+            C = ONE
+            S = ZERO
+            Z( 1 ) = TOL
+         ELSE
+            C = Z1 / Z( 1 )
+            S = -Z( M ) / Z( 1 )
+         END IF
+         CALL SROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
+         CALL SROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
+      ELSE
+         IF( ABS( Z1 ).LE.TOL ) THEN
+            Z( 1 ) = TOL
+         ELSE
+            Z( 1 ) = Z1
+         END IF
+      END IF
+*
+*     Restore Z, VF, and VL.
+*
+      CALL SCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
+      CALL SCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
+      CALL SCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
+*
+      RETURN
+*
+*     End of SLASD7
+*
+      END
diff --git a/SRC/slasd8.f b/SRC/slasd8.f
new file mode 100644
index 00000000..b32ffa2c
--- /dev/null
+++ b/SRC/slasd8.f
@@ -0,0 +1,253 @@
+      SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
+     $                   DSIGMA, WORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, K, LDDIFR
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), DIFL( * ), DIFR( LDDIFR, * ),
+     $                   DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
+     $                   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASD8 finds the square roots of the roots of the secular equation,
+*  as defined by the values in DSIGMA and Z. It makes the appropriate
+*  calls to SLASD4, and stores, for each  element in D, the distance
+*  to its two nearest poles (elements in DSIGMA). It also updates
+*  the arrays VF and VL, the first and last components of all the
+*  right singular vectors of the original bidiagonal matrix.
+*
+*  SLASD8 is called from SLASD6.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ  (input) INTEGER
+*          Specifies whether singular vectors are to be computed in
+*          factored form in the calling routine:
+*          = 0: Compute singular values only.
+*          = 1: Compute singular vectors in factored form as well.
+*
+*  K       (input) INTEGER
+*          The number of terms in the rational function to be solved
+*          by SLASD4.  K >= 1.
+*
+*  D       (output) REAL array, dimension ( K )
+*          On output, D contains the updated singular values.
+*
+*  Z       (input) REAL array, dimension ( K )
+*          The first K elements of this array contain the components
+*          of the deflation-adjusted updating row vector.
+*
+*  VF      (input/output) REAL array, dimension ( K )
+*          On entry, VF contains  information passed through DBEDE8.
+*          On exit, VF contains the first K components of the first
+*          components of all right singular vectors of the bidiagonal
+*          matrix.
+*
+*  VL      (input/output) REAL array, dimension ( K )
+*          On entry, VL contains  information passed through DBEDE8.
+*          On exit, VL contains the first K components of the last
+*          components of all right singular vectors of the bidiagonal
+*          matrix.
+*
+*  DIFL    (output) REAL array, dimension ( K )
+*          On exit, DIFL(I) = D(I) - DSIGMA(I).
+*
+*  DIFR    (output) REAL array,
+*                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
+*                   dimension ( K ) if ICOMPQ = 0.
+*          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
+*          defined and will not be referenced.
+*
+*          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+*          normalizing factors for the right singular vector matrix.
+*
+*  LDDIFR  (input) INTEGER
+*          The leading dimension of DIFR, must be at least K.
+*
+*  DSIGMA  (input) REAL array, dimension ( K )
+*          The first K elements of this array contain the old roots
+*          of the deflated updating problem.  These are the poles
+*          of the secular equation.
+*
+*  WORK    (workspace) REAL array, dimension at least 3 * K
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
+      REAL               DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLASCL, SLASD4, SLASET, XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               SDOT, SLAMC3, SNRM2
+      EXTERNAL           SDOT, SLAMC3, SNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( K.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( LDDIFR.LT.K ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASD8', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.1 ) THEN
+         D( 1 ) = ABS( Z( 1 ) )
+         DIFL( 1 ) = D( 1 )
+         IF( ICOMPQ.EQ.1 ) THEN
+            DIFL( 2 ) = ONE
+            DIFR( 1, 2 ) = ONE
+         END IF
+         RETURN
+      END IF
+*
+*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+*     be computed with high relative accuracy (barring over/underflow).
+*     This is a problem on machines without a guard digit in
+*     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+*     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+*     which on any of these machines zeros out the bottommost
+*     bit of DSIGMA(I) if it is 1; this makes the subsequent
+*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+*     occurs. On binary machines with a guard digit (almost all
+*     machines) it does not change DSIGMA(I) at all. On hexadecimal
+*     and decimal machines with a guard digit, it slightly
+*     changes the bottommost bits of DSIGMA(I). It does not account
+*     for hexadecimal or decimal machines without guard digits
+*     (we know of none). We use a subroutine call to compute
+*     2*DSIGMA(I) to prevent optimizing compilers from eliminating
+*     this code.
+*
+      DO 10 I = 1, K
+         DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+   10 CONTINUE
+*
+*     Book keeping.
+*
+      IWK1 = 1
+      IWK2 = IWK1 + K
+      IWK3 = IWK2 + K
+      IWK2I = IWK2 - 1
+      IWK3I = IWK3 - 1
+*
+*     Normalize Z.
+*
+      RHO = SNRM2( K, Z, 1 )
+      CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+      RHO = RHO*RHO
+*
+*     Initialize WORK(IWK3).
+*
+      CALL SLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
+*
+*     Compute the updated singular values, the arrays DIFL, DIFR,
+*     and the updated Z.
+*
+      DO 40 J = 1, K
+         CALL SLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
+     $                WORK( IWK2 ), INFO )
+*
+*        If the root finder fails, the computation is terminated.
+*
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
+         DIFL( J ) = -WORK( J )
+         DIFR( J, 1 ) = -WORK( J+1 )
+         DO 20 I = 1, J - 1
+            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+     $                        WORK( IWK2I+I ) / ( DSIGMA( I )-
+     $                        DSIGMA( J ) ) / ( DSIGMA( I )+
+     $                        DSIGMA( J ) )
+   20    CONTINUE
+         DO 30 I = J + 1, K
+            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+     $                        WORK( IWK2I+I ) / ( DSIGMA( I )-
+     $                        DSIGMA( J ) ) / ( DSIGMA( I )+
+     $                        DSIGMA( J ) )
+   30    CONTINUE
+   40 CONTINUE
+*
+*     Compute updated Z.
+*
+      DO 50 I = 1, K
+         Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
+   50 CONTINUE
+*
+*     Update VF and VL.
+*
+      DO 80 J = 1, K
+         DIFLJ = DIFL( J )
+         DJ = D( J )
+         DSIGJ = -DSIGMA( J )
+         IF( J.LT.K ) THEN
+            DIFRJ = -DIFR( J, 1 )
+            DSIGJP = -DSIGMA( J+1 )
+         END IF
+         WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
+         DO 60 I = 1, J - 1
+            WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
+     $                   / ( DSIGMA( I )+DJ )
+   60    CONTINUE
+         DO 70 I = J + 1, K
+            WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
+     $                   / ( DSIGMA( I )+DJ )
+   70    CONTINUE
+         TEMP = SNRM2( K, WORK, 1 )
+         WORK( IWK2I+J ) = SDOT( K, WORK, 1, VF, 1 ) / TEMP
+         WORK( IWK3I+J ) = SDOT( K, WORK, 1, VL, 1 ) / TEMP
+         IF( ICOMPQ.EQ.1 ) THEN
+            DIFR( J, 2 ) = TEMP
+         END IF
+   80 CONTINUE
+*
+      CALL SCOPY( K, WORK( IWK2 ), 1, VF, 1 )
+      CALL SCOPY( K, WORK( IWK3 ), 1, VL, 1 )
+*
+      RETURN
+*
+*     End of SLASD8
+*
+      END
diff --git a/SRC/slasda.f b/SRC/slasda.f
new file mode 100644
index 00000000..5092f92a
--- /dev/null
+++ b/SRC/slasda.f
@@ -0,0 +1,389 @@
+      SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
+     $                   DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
+     $                   PERM, GIVNUM, C, S, WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+     $                   K( * ), PERM( LDGCOL, * )
+      REAL               C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
+     $                   E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
+     $                   S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
+     $                   Z( LDU, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Using a divide and conquer approach, SLASDA computes the singular
+*  value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
+*  B with diagonal D and offdiagonal E, where M = N + SQRE. The
+*  algorithm computes the singular values in the SVD B = U * S * VT.
+*  The orthogonal matrices U and VT are optionally computed in
+*  compact form.
+*
+*  A related subroutine, SLASD0, computes the singular values and
+*  the singular vectors in explicit form.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed
+*         in compact form, as follows
+*         = 0: Compute singular values only.
+*         = 1: Compute singular vectors of upper bidiagonal
+*              matrix in compact form.
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The row dimension of the upper bidiagonal matrix. This is
+*         also the dimension of the main diagonal array D.
+*
+*  SQRE   (input) INTEGER
+*         Specifies the column dimension of the bidiagonal matrix.
+*         = 0: The bidiagonal matrix has column dimension M = N;
+*         = 1: The bidiagonal matrix has column dimension M = N + 1.
+*
+*  D      (input/output) REAL array, dimension ( N )
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix. On exit D, if INFO = 0, contains its singular values.
+*
+*  E      (input) REAL array, dimension ( M-1 )
+*         Contains the subdiagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  U      (output) REAL array,
+*         dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
+*         singular vector matrices of all subproblems at the bottom
+*         level.
+*
+*  LDU    (input) INTEGER, LDU = > N.
+*         The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
+*         GIVNUM, and Z.
+*
+*  VT     (output) REAL array,
+*         dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
+*         singular vector matrices of all subproblems at the bottom
+*         level.
+*
+*  K      (output) INTEGER array, dimension ( N ) 
+*         if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
+*         If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
+*         secular equation on the computation tree.
+*
+*  DIFL   (output) REAL array, dimension ( LDU, NLVL ),
+*         where NLVL = floor(log_2 (N/SMLSIZ))).
+*
+*  DIFR   (output) REAL array,
+*                  dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
+*                  dimension ( N ) if ICOMPQ = 0.
+*         If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
+*         record distances between singular values on the I-th
+*         level and singular values on the (I -1)-th level, and
+*         DIFR(1:N, 2 * I ) contains the normalizing factors for
+*         the right singular vector matrix. See SLASD8 for details.
+*
+*  Z      (output) REAL array,
+*                  dimension ( LDU, NLVL ) if ICOMPQ = 1 and
+*                  dimension ( N ) if ICOMPQ = 0.
+*         The first K elements of Z(1, I) contain the components of
+*         the deflation-adjusted updating row vector for subproblems
+*         on the I-th level.
+*
+*  POLES  (output) REAL array,
+*         dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
+*         POLES(1, 2*I) contain  the new and old singular values
+*         involved in the secular equations on the I-th level.
+*
+*  GIVPTR (output) INTEGER array,
+*         dimension ( N ) if ICOMPQ = 1, and not referenced if
+*         ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
+*         the number of Givens rotations performed on the I-th
+*         problem on the computation tree.
+*
+*  GIVCOL (output) INTEGER array,
+*         dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
+*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+*         GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
+*         of Givens rotations performed on the I-th level on the
+*         computation tree.
+*
+*  LDGCOL (input) INTEGER, LDGCOL = > N.
+*         The leading dimension of arrays GIVCOL and PERM.
+*
+*  PERM   (output) INTEGER array, dimension ( LDGCOL, NLVL ) 
+*         if ICOMPQ = 1, and not referenced
+*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
+*         permutations done on the I-th level of the computation tree.
+*
+*  GIVNUM (output) REAL array,
+*         dimension ( LDU,  2 * NLVL ) if ICOMPQ = 1, and not
+*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+*         GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
+*         values of Givens rotations performed on the I-th level on
+*         the computation tree.
+*
+*  C      (output) REAL array,
+*         dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
+*         If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
+*         C( I ) contains the C-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  S      (output) REAL array, dimension ( N ) if
+*         ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
+*         and the I-th subproblem is not square, on exit, S( I )
+*         contains the S-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  WORK   (workspace) REAL array, dimension
+*         (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
+*
+*  IWORK  (workspace) INTEGER array, dimension (7*N).
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an singular value did not converge
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
+     $                   J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
+     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
+     $                   NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
+      REAL               ALPHA, BETA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLASD6, SLASDQ, SLASDT, SLASET, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      ELSE IF( LDU.LT.( N+SQRE ) ) THEN
+         INFO = -8
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -17
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASDA', -INFO )
+         RETURN
+      END IF
+*
+      M = N + SQRE
+*
+*     If the input matrix is too small, call SLASDQ to find the SVD.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL SLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
+     $                   U, LDU, WORK, INFO )
+         ELSE
+            CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
+     $                   U, LDU, WORK, INFO )
+         END IF
+         RETURN
+      END IF
+*
+*     Book-keeping and  set up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+      IDXQ = NDIMR + N
+      IWK = IDXQ + N
+*
+      NCC = 0
+      NRU = 0
+*
+      SMLSZP = SMLSIZ + 1
+      VF = 1
+      VL = VF + M
+      NWORK1 = VL + M
+      NWORK2 = NWORK1 + SMLSZP*SMLSZP
+*
+      CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     for the nodes on bottom level of the tree, solve
+*     their subproblems by SLASDQ.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 30 I = NDB1, ND
+*
+*        IC : center row of each node
+*        NL : number of rows of left  subproblem
+*        NR : number of rows of right subproblem
+*        NLF: starting row of the left   subproblem
+*        NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NLP1 = NL + 1
+         NR = IWORK( NDIMR+I1 )
+         NLF = IC - NL
+         NRF = IC + 1
+         IDXQI = IDXQ + NLF - 2
+         VFI = VF + NLF - 1
+         VLI = VL + NLF - 1
+         SQREI = 1
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
+     $                   SMLSZP )
+            CALL SLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
+     $                   E( NLF ), WORK( NWORK1 ), SMLSZP,
+     $                   WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
+     $                   WORK( NWORK2 ), INFO )
+            ITEMP = NWORK1 + NL*SMLSZP
+            CALL SCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+            CALL SCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+         ELSE
+            CALL SLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
+            CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
+            CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
+     $                   E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
+     $                   U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
+            CALL SCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
+            CALL SCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
+         END IF
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         DO 10 J = 1, NL
+            IWORK( IDXQI+J ) = J
+   10    CONTINUE
+         IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
+            SQREI = 0
+         ELSE
+            SQREI = 1
+         END IF
+         IDXQI = IDXQI + NLP1
+         VFI = VFI + NLP1
+         VLI = VLI + NLP1
+         NRP1 = NR + SQREI
+         IF( ICOMPQ.EQ.0 ) THEN
+            CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
+     $                   SMLSZP )
+            CALL SLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
+     $                   E( NRF ), WORK( NWORK1 ), SMLSZP,
+     $                   WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
+     $                   WORK( NWORK2 ), INFO )
+            ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
+            CALL SCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+            CALL SCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+         ELSE
+            CALL SLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
+            CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
+            CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
+     $                   E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
+     $                   U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
+            CALL SCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
+            CALL SCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
+         END IF
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+         DO 20 J = 1, NR
+            IWORK( IDXQI+J ) = J
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Now conquer each subproblem bottom-up.
+*
+      J = 2**NLVL
+      DO 50 LVL = NLVL, 1, -1
+         LVL2 = LVL*2 - 1
+*
+*        Find the first node LF and last node LL on
+*        the current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 40 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            IF( I.EQ.LL ) THEN
+               SQREI = SQRE
+            ELSE
+               SQREI = 1
+            END IF
+            VFI = VF + NLF - 1
+            VLI = VL + NLF - 1
+            IDXQI = IDXQ + NLF - 1
+            ALPHA = D( IC )
+            BETA = E( IC )
+            IF( ICOMPQ.EQ.0 ) THEN
+               CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+     $                      WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+     $                      IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
+     $                      LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
+     $                      K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
+     $                      IWORK( IWK ), INFO )
+            ELSE
+               J = J - 1
+               CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+     $                      WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+     $                      IWORK( IDXQI ), PERM( NLF, LVL ),
+     $                      GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                      GIVNUM( NLF, LVL2 ), LDU,
+     $                      POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
+     $                      DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
+     $                      C( J ), S( J ), WORK( NWORK1 ),
+     $                      IWORK( IWK ), INFO )
+            END IF
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+   40    CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of SLASDA
+*
+      END
diff --git a/SRC/slasdq.f b/SRC/slasdq.f
new file mode 100644
index 00000000..596cf676
--- /dev/null
+++ b/SRC/slasdq.f
@@ -0,0 +1,316 @@
+      SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
+     $                   U, LDU, C, LDC, WORK, INFO )
+*
+*  -- LAPACK auxiliary 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, SQRE
+*     ..
+*     .. Array Arguments ..
+      REAL               C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASDQ computes the singular value decomposition (SVD) of a real
+*  (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
+*  E, accumulating the transformations if desired. Letting B denote
+*  the input bidiagonal matrix, the algorithm computes orthogonal
+*  matrices Q and P such that B = Q * S * P' (P' denotes the transpose
+*  of P). The singular values S are overwritten on D.
+*
+*  The input matrix U  is changed to U  * Q  if desired.
+*  The input matrix VT is changed to P' * VT if desired.
+*  The input matrix C  is changed to Q' * C  if desired.
+*
+*  See "Computing  Small Singular Values of Bidiagonal Matrices With
+*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+*  LAPACK Working Note #3, for a detailed description of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO  (input) CHARACTER*1
+*        On entry, UPLO specifies whether the input bidiagonal matrix
+*        is upper or lower bidiagonal, and wether it is square are
+*        not.
+*           UPLO = 'U' or 'u'   B is upper bidiagonal.
+*           UPLO = 'L' or 'l'   B is lower bidiagonal.
+*
+*  SQRE  (input) INTEGER
+*        = 0: then the input matrix is N-by-N.
+*        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
+*             (N+1)-by-N if UPLU = 'L'.
+*
+*        The bidiagonal matrix has
+*        N = NL + NR + 1 rows and
+*        M = N + SQRE >= N columns.
+*
+*  N     (input) INTEGER
+*        On entry, N specifies the number of rows and columns
+*        in the matrix. N must be at least 0.
+*
+*  NCVT  (input) INTEGER
+*        On entry, NCVT specifies the number of columns of
+*        the matrix VT. NCVT must be at least 0.
+*
+*  NRU   (input) INTEGER
+*        On entry, NRU specifies the number of rows of
+*        the matrix U. NRU must be at least 0.
+*
+*  NCC   (input) INTEGER
+*        On entry, NCC specifies the number of columns of
+*        the matrix C. NCC must be at least 0.
+*
+*  D     (input/output) REAL array, dimension (N)
+*        On entry, D contains the diagonal entries of the
+*        bidiagonal matrix whose SVD is desired. On normal exit,
+*        D contains the singular values in ascending order.
+*
+*  E     (input/output) REAL array.
+*        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
+*        On entry, the entries of E contain the offdiagonal entries
+*        of the bidiagonal matrix whose SVD is desired. On normal
+*        exit, E will contain 0. If the algorithm does not converge,
+*        D and E will contain the diagonal and superdiagonal entries
+*        of a bidiagonal matrix orthogonally equivalent to the one
+*        given as input.
+*
+*  VT    (input/output) REAL array, dimension (LDVT, NCVT)
+*        On entry, contains a matrix which on exit has been
+*        premultiplied by P', dimension N-by-NCVT if SQRE = 0
+*        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
+*
+*  LDVT  (input) INTEGER
+*        On entry, LDVT specifies the leading dimension of VT as
+*        declared in the calling (sub) program. LDVT must be at
+*        least 1. If NCVT is nonzero LDVT must also be at least N.
+*
+*  U     (input/output) REAL array, dimension (LDU, N)
+*        On entry, contains a  matrix which on exit has been
+*        postmultiplied by Q, dimension NRU-by-N if SQRE = 0
+*        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
+*
+*  LDU   (input) INTEGER
+*        On entry, LDU  specifies the leading dimension of U as
+*        declared in the calling (sub) program. LDU must be at
+*        least max( 1, NRU ) .
+*
+*  C     (input/output) REAL array, dimension (LDC, NCC)
+*        On entry, contains an N-by-NCC matrix which on exit
+*        has been premultiplied by Q'  dimension N-by-NCC if SQRE = 0
+*        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
+*
+*  LDC   (input) INTEGER
+*        On entry, LDC  specifies the leading dimension of C as
+*        declared in the calling (sub) program. LDC must be at
+*        least 1. If NCC is nonzero, LDC must also be at least N.
+*
+*  WORK  (workspace) REAL array, dimension (4*N)
+*        Workspace. Only referenced if one of NCVT, NRU, or NCC is
+*        nonzero, and if N is at least 2.
+*
+*  INFO  (output) INTEGER
+*        On exit, a value of 0 indicates a successful exit.
+*        If INFO < 0, argument number -INFO is illegal.
+*        If INFO > 0, the algorithm did not converge, and INFO
+*        specifies how many superdiagonals did not converge.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ROTATE
+      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
+      REAL               CS, R, SMIN, SN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SBDSQR, SLARTG, SLASR, SSWAP, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IUPLO = 0
+      IF( LSAME( UPLO, 'U' ) )
+     $   IUPLO = 1
+      IF( LSAME( UPLO, 'L' ) )
+     $   IUPLO = 2
+      IF( IUPLO.EQ.0 ) THEN
+         INFO = -1
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NCVT.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRU.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+         INFO = -10
+      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+         INFO = -12
+      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLASDQ', -INFO )
+         RETURN
+      END IF
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     ROTATE is true if any singular vectors desired, false otherwise
+*
+      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+      NP1 = N + 1
+      SQRE1 = SQRE
+*
+*     If matrix non-square upper bidiagonal, rotate to be lower
+*     bidiagonal.  The rotations are on the right.
+*
+      IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
+         DO 10 I = 1, N - 1
+            CALL SLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( ROTATE ) THEN
+               WORK( I ) = CS
+               WORK( N+I ) = SN
+            END IF
+   10    CONTINUE
+         CALL SLARTG( D( N ), E( N ), CS, SN, R )
+         D( N ) = R
+         E( N ) = ZERO
+         IF( ROTATE ) THEN
+            WORK( N ) = CS
+            WORK( N+N ) = SN
+         END IF
+         IUPLO = 2
+         SQRE1 = 0
+*
+*        Update singular vectors if desired.
+*
+         IF( NCVT.GT.0 )
+     $      CALL SLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
+     $                  WORK( NP1 ), VT, LDVT )
+      END IF
+*
+*     If matrix lower bidiagonal, rotate to be upper bidiagonal
+*     by applying Givens rotations on the left.
+*
+      IF( IUPLO.EQ.2 ) THEN
+         DO 20 I = 1, N - 1
+            CALL SLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( ROTATE ) THEN
+               WORK( I ) = CS
+               WORK( N+I ) = SN
+            END IF
+   20    CONTINUE
+*
+*        If matrix (N+1)-by-N lower bidiagonal, one additional
+*        rotation is needed.
+*
+         IF( SQRE1.EQ.1 ) THEN
+            CALL SLARTG( D( N ), E( N ), CS, SN, R )
+            D( N ) = R
+            IF( ROTATE ) THEN
+               WORK( N ) = CS
+               WORK( N+N ) = SN
+            END IF
+         END IF
+*
+*        Update singular vectors if desired.
+*
+         IF( NRU.GT.0 ) THEN
+            IF( SQRE1.EQ.0 ) THEN
+               CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
+     $                     WORK( NP1 ), U, LDU )
+            ELSE
+               CALL SLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
+     $                     WORK( NP1 ), U, LDU )
+            END IF
+         END IF
+         IF( NCC.GT.0 ) THEN
+            IF( SQRE1.EQ.0 ) THEN
+               CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
+     $                     WORK( NP1 ), C, LDC )
+            ELSE
+               CALL SLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
+     $                     WORK( NP1 ), C, LDC )
+            END IF
+         END IF
+      END IF
+*
+*     Call SBDSQR to compute the SVD of the reduced real
+*     N-by-N upper bidiagonal matrix.
+*
+      CALL SBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
+     $             LDC, WORK, INFO )
+*
+*     Sort the singular values into ascending order (insertion sort on
+*     singular values, but only one transposition per singular vector)
+*
+      DO 40 I = 1, N
+*
+*        Scan for smallest D(I).
+*
+         ISUB = I
+         SMIN = D( I )
+         DO 30 J = I + 1, N
+            IF( D( J ).LT.SMIN ) THEN
+               ISUB = J
+               SMIN = D( J )
+            END IF
+   30    CONTINUE
+         IF( ISUB.NE.I ) THEN
+*
+*           Swap singular values and vectors.
+*
+            D( ISUB ) = D( I )
+            D( I ) = SMIN
+            IF( NCVT.GT.0 )
+     $         CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
+         END IF
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of SLASDQ
+*
+      END
diff --git a/SRC/slasdt.f b/SRC/slasdt.f
new file mode 100644
index 00000000..335935c0
--- /dev/null
+++ b/SRC/slasdt.f
@@ -0,0 +1,105 @@
+      SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LVL, MSUB, N, ND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            INODE( * ), NDIML( * ), NDIMR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASDT creates a tree of subproblems for bidiagonal divide and
+*  conquer.
+*
+*  Arguments
+*  =========
+*
+*   N      (input) INTEGER
+*          On entry, the number of diagonal elements of the
+*          bidiagonal matrix.
+*
+*   LVL    (output) INTEGER
+*          On exit, the number of levels on the computation tree.
+*
+*   ND     (output) INTEGER
+*          On exit, the number of nodes on the tree.
+*
+*   INODE  (output) INTEGER array, dimension ( N )
+*          On exit, centers of subproblems.
+*
+*   NDIML  (output) INTEGER array, dimension ( N )
+*          On exit, row dimensions of left children.
+*
+*   NDIMR  (output) INTEGER array, dimension ( N )
+*          On exit, row dimensions of right children.
+*
+*   MSUB   (input) INTEGER.
+*          On entry, the maximum row dimension each subproblem at the
+*          bottom of the tree can be of.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IL, IR, LLST, MAXN, NCRNT, NLVL
+      REAL               TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, LOG, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Find the number of levels on the tree.
+*
+      MAXN = MAX( 1, N )
+      TEMP = LOG( REAL( MAXN ) / REAL( MSUB+1 ) ) / LOG( TWO )
+      LVL = INT( TEMP ) + 1
+*
+      I = N / 2
+      INODE( 1 ) = I + 1
+      NDIML( 1 ) = I
+      NDIMR( 1 ) = N - I - 1
+      IL = 0
+      IR = 1
+      LLST = 1
+      DO 20 NLVL = 1, LVL - 1
+*
+*        Constructing the tree at (NLVL+1)-st level. The number of
+*        nodes created on this level is LLST * 2.
+*
+         DO 10 I = 0, LLST - 1
+            IL = IL + 2
+            IR = IR + 2
+            NCRNT = LLST + I
+            NDIML( IL ) = NDIML( NCRNT ) / 2
+            NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
+            INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
+            NDIML( IR ) = NDIMR( NCRNT ) / 2
+            NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
+            INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
+   10    CONTINUE
+         LLST = LLST*2
+   20 CONTINUE
+      ND = LLST*2 - 1
+*
+      RETURN
+*
+*     End of SLASDT
+*
+      END
diff --git a/SRC/slaset.f b/SRC/slaset.f
new file mode 100644
index 00000000..7acc0cad
--- /dev/null
+++ b/SRC/slaset.f
@@ -0,0 +1,114 @@
+      SUBROUTINE SLASET( 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
+      REAL               ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASET 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) REAL
+*          The constant to which the offdiagonal elements are to be set.
+*
+*  BETA    (input) REAL
+*          The constant to which the diagonal elements are to be set.
+*
+*  A       (input/output) REAL 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 SLASET
+*
+      END
diff --git a/SRC/slasq1.f b/SRC/slasq1.f
new file mode 100644
index 00000000..bc8a2f1e
--- /dev/null
+++ b/SRC/slasq1.f
@@ -0,0 +1,148 @@
+      SUBROUTINE SLASQ1( 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 ..
+      REAL               D( * ), E( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASQ1 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO
+      REAL               EPS, SCALE, SAFMIN, SIGMN, SIGMX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAS2, SLASCL, SLASQ2, SLASRT, XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -2
+         CALL XERBLA( 'SLASQ1', -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 SLAS2( 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 SLASRT( '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 = SLAMCH( 'Precision' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SCALE = SQRT( EPS / SAFMIN )
+      CALL SCOPY( N, D, 1, WORK( 1 ), 2 )
+      CALL SCOPY( N-1, E, 1, WORK( 2 ), 2 )
+      CALL SLASCL( '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 SLASQ2( N, WORK, INFO )
+*
+      IF( INFO.EQ.0 ) THEN
+         DO 40 I = 1, N
+            D( I ) = SQRT( WORK( I ) )
+   40    CONTINUE
+         CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
+      END IF
+*
+      RETURN
+*
+*     End of SLASQ1
+*
+      END
diff --git a/SRC/slasq2.f b/SRC/slasq2.f
new file mode 100644
index 00000000..9fd6fa01
--- /dev/null
+++ b/SRC/slasq2.f
@@ -0,0 +1,448 @@
+      SUBROUTINE SLASQ2( N, Z, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call SLAZQ3 in place of SLASQ3, 13 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASQ2 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 : SLASQ2 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 SLAZQ3.
+*
+*  Arguments
+*  =========
+*
+*  N     (input) INTEGER
+*        The number of rows and columns in the matrix. N >= 0.
+*
+*  Z     (workspace) REAL 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 ..
+      REAL               CBIAS
+      PARAMETER          ( CBIAS = 1.50E0 )
+      REAL               ZERO, HALF, ONE, TWO, FOUR, HUNDRD
+      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
+     $                     TWO = 2.0E0, FOUR = 4.0E0, HUNDRD = 100.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            IEEE
+      INTEGER            I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, 
+     $                   N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
+      REAL               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           SLAZQ3, SLASRT, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      REAL               SLAMCH
+      EXTERNAL           ILAENV, SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*      
+*     Test the input arguments.
+*     (in case SLASQ2 is not called by SLASQ1)
+*
+      INFO = 0
+      EPS = SLAMCH( 'Precision' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      TOL = EPS*HUNDRD
+      TOL2 = TOL**2
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'SLASQ2', 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( 'SLASQ2', 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( 'SLASQ2', 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( 'SLASQ2', 2 )
+            RETURN
+         ELSE IF( Z( K+1 ).LT.ZERO ) THEN
+            INFO = -( 200+K+1 )
+            CALL XERBLA( 'SLASQ2', 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( 'SLASQ2', 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 SLASRT( '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, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
+     $       ILAENV( 11, 'SLASQ2', '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 SLAZQ3
+*
+      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 SLAZQ3.
+*
+         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 SLAZQ3( 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 SLASRT( '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 ) = REAL( ITER )
+      Z( 2*N+4 ) = REAL( NDIV ) / REAL( N**2 )
+      Z( 2*N+5 ) = HUNDRD*NFAIL / REAL( ITER )
+      RETURN
+*
+*     End of SLASQ2
+*
+      END
diff --git a/SRC/slasq3.f b/SRC/slasq3.f
new file mode 100644
index 00000000..e72dde33
--- /dev/null
+++ b/SRC/slasq3.f
@@ -0,0 +1,295 @@
+      SUBROUTINE SLASQ3( 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
+      REAL               DESIG, DMIN, QMAX, SIGMA
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASQ3 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) REAL array, dimension ( 4*N )
+*         Z holds the qd array.
+*
+*  PP     (input) INTEGER
+*         PP=0 for ping, PP=1 for pong.
+*
+*  DMIN   (output) REAL
+*         Minimum value of d.
+*
+*  SIGMA  (output) REAL
+*         Sum of shifts used in current segment.
+*
+*  DESIG  (input/output) REAL
+*         Lower order part of SIGMA
+*
+*  QMAX   (input) REAL
+*         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 SLASQ5).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               CBIAS
+      PARAMETER          ( CBIAS = 1.50E0 )
+      REAL               ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+      PARAMETER          ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
+     $                     ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IPN4, J4, N0IN, NN, TTYPE
+      REAL               DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
+     $                   TAU, TEMP, TOL, TOL2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASQ4, SLASQ5, SLASQ6
+*     ..
+*     .. External Function ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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 = SLAMCH( 'Precision' )
+      SAFMIN = SLAMCH( '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 SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+     $                DN2, TAU, TTYPE )
+*
+*        Call dqds until DMIN > 0.
+*
+   80    CONTINUE
+*
+         CALL SLASQ5( 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 SLASQ6( 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 SLASQ3
+*
+      END
diff --git a/SRC/slasq4.f b/SRC/slasq4.f
new file mode 100644
index 00000000..1c4bc62e
--- /dev/null
+++ b/SRC/slasq4.f
@@ -0,0 +1,329 @@
+      SUBROUTINE SLASQ4( 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
+      REAL               DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASQ4 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) REAL 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) REAL
+*        Minimum value of d.
+*
+*  DMIN1 (input) REAL
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (input) REAL
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (input) REAL
+*        d(N)
+*
+*  DN1   (input) REAL
+*        d(N-1)
+*
+*  DN2   (input) REAL
+*        d(N-2)
+*
+*  TAU   (output) REAL
+*        This is the shift.
+*
+*  TTYPE (output) INTEGER
+*        Shift type.
+*
+*  Further Details
+*  ===============
+*  CNST1 = 9/16
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               CNST1, CNST2, CNST3
+      PARAMETER          ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
+     $                   CNST3 = 1.050E0 )
+      REAL               QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+      PARAMETER          ( QURTR = 0.250E0, THIRD = 0.3330E0,
+     $                   HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
+     $                   TWO = 2.0E0, HUNDRD = 100.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I4, NN, NP
+      REAL               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 SLASQ4
+*
+      END
diff --git a/SRC/slasq5.f b/SRC/slasq5.f
new file mode 100644
index 00000000..64669582
--- /dev/null
+++ b/SRC/slasq5.f
@@ -0,0 +1,195 @@
+      SUBROUTINE SLASQ5( 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
+      REAL               DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASQ5 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) REAL 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) REAL
+*        This is the shift.
+*
+*  DMIN  (output) REAL
+*        Minimum value of d.
+*
+*  DMIN1 (output) REAL
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (output) REAL
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (output) REAL
+*        d(N0), the last value of d.
+*
+*  DNM1  (output) REAL
+*        d(N0-1).
+*
+*  DNM2  (output) REAL
+*        d(N0-2).
+*
+*  IEEE  (input) LOGICAL
+*        Flag for IEEE or non IEEE arithmetic.
+*
+*  =====================================================================
+*
+*     .. Parameter ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J4, J4P2
+      REAL               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 SLASQ5
+*
+      END
diff --git a/SRC/slasq6.f b/SRC/slasq6.f
new file mode 100644
index 00000000..f09d8cff
--- /dev/null
+++ b/SRC/slasq6.f
@@ -0,0 +1,175 @@
+      SUBROUTINE SLASQ6( 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
+      REAL               DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASQ6 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) REAL 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) REAL
+*        Minimum value of d.
+*
+*  DMIN1 (output) REAL
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (output) REAL
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (output) REAL
+*        d(N0), the last value of d.
+*
+*  DNM1  (output) REAL
+*        d(N0-1).
+*
+*  DNM2  (output) REAL
+*        d(N0-2).
+*
+*  =====================================================================
+*
+*     .. Parameter ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J4, J4P2
+      REAL               D, EMIN, SAFMIN, TEMP
+*     ..
+*     .. External Function ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ( N0-I0-1 ).LE.0 )
+     $   RETURN
+*
+      SAFMIN = SLAMCH( '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 SLASQ6
+*
+      END
diff --git a/SRC/slasr.f b/SRC/slasr.f
new file mode 100644
index 00000000..651d9a47
--- /dev/null
+++ b/SRC/slasr.f
@@ -0,0 +1,361 @@
+      SUBROUTINE SLASR( 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 ..
+      REAL               A( LDA, * ), C( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASR 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) REAL array, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          The cosines c(k) of the plane rotations.
+*
+*  S       (input) REAL 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+      REAL               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( 'SLASR ', 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 SLASR
+*
+      END
diff --git a/SRC/slasrt.f b/SRC/slasrt.f
new file mode 100644
index 00000000..a6188c06
--- /dev/null
+++ b/SRC/slasrt.f
@@ -0,0 +1,243 @@
+      SUBROUTINE SLASRT( 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 ..
+      REAL               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) REAL 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
+      REAL               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( 'SLASRT', -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 SLASRT
+*
+      END
diff --git a/SRC/slassq.f b/SRC/slassq.f
new file mode 100644
index 00000000..e69b3a8c
--- /dev/null
+++ b/SRC/slassq.f
@@ -0,0 +1,88 @@
+      SUBROUTINE SLASSQ( 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
+      REAL               SCALE, SUMSQ
+*     ..
+*     .. Array Arguments ..
+      REAL               X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASSQ  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) REAL 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) REAL
+*          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) REAL
+*          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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IX
+      REAL               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 SLASSQ
+*
+      END
diff --git a/SRC/slasv2.f b/SRC/slasv2.f
new file mode 100644
index 00000000..a8717302
--- /dev/null
+++ b/SRC/slasv2.f
@@ -0,0 +1,249 @@
+      SUBROUTINE SLASV2( 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 ..
+      REAL               CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASV2 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) REAL
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  G       (input) REAL
+*          The (1,2) element of the 2-by-2 matrix.
+*
+*  H       (input) REAL
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  SSMIN   (output) REAL
+*          abs(SSMIN) is the smaller singular value.
+*
+*  SSMAX   (output) REAL
+*          abs(SSMAX) is the larger singular value.
+*
+*  SNL     (output) REAL
+*  CSL     (output) REAL
+*          The vector (CSL, SNL) is a unit left singular vector for the
+*          singular value abs(SSMAX).
+*
+*  SNR     (output) REAL
+*  CSR     (output) REAL
+*          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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E0 )
+      REAL               HALF
+      PARAMETER          ( HALF = 0.5E0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E0 )
+      REAL               FOUR
+      PARAMETER          ( FOUR = 4.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            GASMAL, SWAP
+      INTEGER            PMAX
+      REAL               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 ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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.SLAMCH( '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 SLASV2
+*
+      END
diff --git a/SRC/slaswp.f b/SRC/slaswp.f
new file mode 100644
index 00000000..8b79fb72
--- /dev/null
+++ b/SRC/slaswp.f
@@ -0,0 +1,119 @@
+      SUBROUTINE SLASWP( 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( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASWP 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) REAL 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
+      REAL               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 SLASWP
+*
+      END
diff --git a/SRC/slasy2.f b/SRC/slasy2.f
new file mode 100644
index 00000000..fb88a081
--- /dev/null
+++ b/SRC/slasy2.f
@@ -0,0 +1,381 @@
+      SUBROUTINE SLASY2( 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
+      REAL               SCALE, XNORM
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASY2 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) REAL 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) REAL 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) REAL 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) REAL
+*          On exit, SCALE contains the scale factor. SCALE is chosen
+*          less than or equal to 1 to prevent the solution overflowing.
+*
+*  X       (output) REAL 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) REAL
+*          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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               TWO, HALF, EIGHT
+      PARAMETER          ( TWO = 2.0E+0, HALF = 0.5E+0, EIGHT = 8.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            BSWAP, XSWAP
+      INTEGER            I, IP, IPIV, IPSV, J, JP, JPSV, K
+      REAL               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 )
+      REAL               BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SSWAP
+*     ..
+*     .. 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 = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( '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 = ISAMAX( 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 SCOPY( 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 SSWAP( 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 SSWAP( 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 SLASY2
+*
+      END
diff --git a/SRC/slasyf.f b/SRC/slasyf.f
new file mode 100644
index 00000000..545d2a32
--- /dev/null
+++ b/SRC/slasyf.f
@@ -0,0 +1,587 @@
+      SUBROUTINE SLASYF( 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( * )
+      REAL               A( LDA, * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLASYF 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.
+*
+*  SLASYF is an auxiliary routine called by SSYTRF. 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+     $                   KSTEP, KW
+      REAL               ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
+     $                   ROWMAX, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      EXTERNAL           LSAME, ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMM, SGEMV, SSCAL, SSWAP
+*     ..
+*     .. 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 SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+         IF( K.LT.N )
+     $      CALL SGEMV( '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 = ISAMAX( 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 SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+               CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+     $                     W( IMAX+1, KW-1 ), 1 )
+               IF( K.LT.N )
+     $            CALL SGEMV( '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 + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               ROWMAX = ABS( W( JMAX, KW-1 ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ISAMAX( 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 SCOPY( 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 SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+*              Interchange rows KK and KP in last KK columns of A and W
+*
+               CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+               CALL SSWAP( 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 SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+               R1 = ONE / A( K, K )
+               CALL SSCAL( 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 SGEMV( '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 SGEMM( '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 SSWAP( 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 SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+         CALL SGEMV( '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 + ISAMAX( 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 SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+               CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
+     $                     1 )
+               CALL SGEMV( '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 + ISAMAX( IMAX-K, W( K, K+1 ), 1 )
+               ROWMAX = ABS( W( JMAX, K+1 ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + ISAMAX( 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 SCOPY( 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 SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+               CALL SCOPY( 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 SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+               CALL SSWAP( 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 SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+               IF( K.LT.N ) THEN
+                  R1 = ONE / A( K, K )
+                  CALL SSCAL( 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 SGEMV( '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 SGEMM( '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 SSWAP( 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 SLASYF
+*
+      END
diff --git a/SRC/slatbs.f b/SRC/slatbs.f
new file mode 100644
index 00000000..04c425b3
--- /dev/null
+++ b/SRC/slatbs.f
@@ -0,0 +1,723 @@
+      SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, 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, KD, LDAB, N
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), CNORM( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLATBS solves one of the triangular systems
+*
+*     A *x = s*b  or  A'*x = s*b
+*
+*  with scaling to prevent overflow, where A is an upper or lower
+*  triangular band matrix.  Here 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 STBSV 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.
+*
+*  KD      (input) INTEGER
+*          The number of subdiagonals or superdiagonals in the
+*          triangular matrix A.  KD >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first KD+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  X       (input/output) REAL 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) REAL
+*          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) REAL 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, STBSV
+*  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 STBSV 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 STBSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
+      REAL               BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SASUM, SDOT, SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SASUM, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SSCAL, STBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLATBS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            DO 10 J = 1, N
+               JLEN = MIN( KD, J-1 )
+               CNORM( J ) = SASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N
+               JLEN = MIN( KD, N-J )
+               IF( JLEN.GT.0 ) THEN
+                  CNORM( J ) = SASUM( JLEN, AB( 2, J ), 1 )
+               ELSE
+                  CNORM( J ) = ZERO
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM.
+*
+      IMAX = ISAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = ONE / ( SMLNUM*TMAX )
+         CALL SSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine STBSV can be used.
+*
+      J = ISAMAX( N, X, 1 )
+      XMAX = ABS( X( J ) )
+      XBND = XMAX
+      IF( NOTRAN ) THEN
+*
+*        Compute the growth in A * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+            MAIND = KD + 1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+            MAIND = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 50
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 30 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              M(j) = G(j-1) / abs(A(j,j))
+*
+               TJJ = ABS( AB( MAIND, J ) )
+               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+               ELSE
+*
+*                 G(j) could overflow, set GROW to 0.
+*
+                  GROW = ZERO
+               END IF
+   30       CONTINUE
+            GROW = XBND
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+   40       CONTINUE
+         END IF
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute the growth in A' * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+            MAIND = KD + 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+            MAIND = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 80
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, M(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 60 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+               XJ = ONE + CNORM( J )
+               GROW = MIN( GROW, XBND / XJ )
+*
+*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+               TJJ = ABS( AB( MAIND, J ) )
+               IF( XJ.GT.TJJ )
+     $            XBND = XBND*( TJJ / XJ )
+   60       CONTINUE
+            GROW = MIN( GROW, XBND )
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 70 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+               XJ = ONE + CNORM( J )
+               GROW = GROW / XJ
+   70       CONTINUE
+         END IF
+   80    CONTINUE
+      END IF
+*
+      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+*        Use the Level 2 BLAS solve if the reciprocal of the bound on
+*        elements of X is not too small.
+*
+         CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
+      ELSE
+*
+*        Use a Level 1 BLAS solve, scaling intermediate results.
+*
+         IF( XMAX.GT.BIGNUM ) THEN
+*
+*           Scale X so that its components are less than or equal to
+*           BIGNUM in absolute value.
+*
+            SCALE = BIGNUM / XMAX
+            CALL SSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            DO 100 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = ABS( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = AB( MAIND, J )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 95
+               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 SSCAL( 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 SSCAL( 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
+   95          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 SSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL SSCAL( N, HALF, X, 1 )
+                  SCALE = SCALE*HALF
+               END IF
+*
+               IF( UPPER ) THEN
+                  IF( J.GT.1 ) THEN
+*
+*                    Compute the update
+*                       x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
+*                                             x(j)* A(max(1,j-kd):j-1,j)
+*
+                     JLEN = MIN( KD, J-1 )
+                     CALL SAXPY( JLEN, -X( J )*TSCAL,
+     $                           AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
+                     I = ISAMAX( J-1, X, 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+               ELSE IF( J.LT.N ) THEN
+*
+*                 Compute the update
+*                    x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
+*                                          x(j) * A(j+1:min(j+kd,n),j)
+*
+                  JLEN = MIN( KD, N-J )
+                  IF( JLEN.GT.0 )
+     $               CALL SAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
+     $                           X( J+1 ), 1 )
+                  I = J + ISAMAX( N-J, X( J+1 ), 1 )
+                  XMAX = ABS( X( I ) )
+               END IF
+  100       CONTINUE
+*
+         ELSE
+*
+*           Solve A' * x = b
+*
+            DO 140 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = ABS( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = AB( MAIND, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                     TJJ = ABS( TJJS )
+                     IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                        REC = MIN( ONE, REC*TJJ )
+                        USCAL = USCAL / TJJS
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL SSCAL( 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 SDOT to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     SUMJ = SDOT( JLEN, AB( KD+1-JLEN, J ), 1,
+     $                      X( J-JLEN ), 1 )
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     IF( JLEN.GT.0 )
+     $                  SUMJ = SDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     DO 110 I = 1, JLEN
+                        SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
+     $                         X( J-JLEN-1+I )
+  110                CONTINUE
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     DO 120 I = 1, JLEN
+                        SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
+  120                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.TSCAL ) THEN
+*
+*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - SUMJ
+                  XJ = ABS( X( J ) )
+                  IF( NOUNIT ) THEN
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AB( MAIND, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 135
+                  END IF
+                     TJJ = ABS( TJJS )
+                     IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                        IF( TJJ.LT.ONE ) THEN
+                           IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                              REC = ONE / XJ
+                              CALL SSCAL( 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 SSCAL( 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 130 I = 1, N
+                           X( I ) = ZERO
+  130                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  135             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 ) ) )
+  140       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of SLATBS
+*
+      END
diff --git a/SRC/slatdf.f b/SRC/slatdf.f
new file mode 100644
index 00000000..43156c7c
--- /dev/null
+++ b/SRC/slatdf.f
@@ -0,0 +1,237 @@
+      SUBROUTINE SLATDF( 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
+      REAL               RDSCAL, RDSUM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      REAL               RHS( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLATDF uses the LU factorization of the n-by-n matrix Z computed by
+*  SGETC2 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 SGETC2 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 SGECON, 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) REAL array, dimension (LDZ, N)
+*          On entry, the LU part of the factorization of the n-by-n
+*          matrix Z computed by SGETC2:  Z = P * L * U * Q
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDA >= max(1, N).
+*
+*  RHS     (input/output) REAL 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) REAL
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by STGSYL, 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 STGSY2 is called by STGSYL.
+*
+*  RDSCAL  (input/output) REAL
+*          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 STGSY2 is called by
+*                STGSYL.
+*
+*  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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J, K
+      REAL               BM, BP, PMONE, SMINU, SPLUS, TEMP
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IWORK( MAXDIM )
+      REAL               WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGECON, SGESC2, SLASSQ, SLASWP,
+     $                   SSCAL
+*     ..
+*     .. External Functions ..
+      REAL               SASUM, SDOT
+      EXTERNAL           SASUM, SDOT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( IJOB.NE.2 ) THEN
+*
+*        Apply permutations IPIV to RHS
+*
+         CALL SLASWP( 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 + SDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
+            SMINU = SDOT( 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 SAXPY( 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 SCOPY( 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 SCOPY( N, XP, 1, RHS, 1 )
+*
+*        Apply the permutations JPIV to the computed solution (RHS)
+*
+         CALL SLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
+*
+*        Compute the sum of squares
+*
+         CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+      ELSE
+*
+*        IJOB = 2, Compute approximate nullvector XM of Z
+*
+         CALL SGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
+         CALL SCOPY( N, WORK( N+1 ), 1, XM, 1 )
+*
+*        Compute RHS
+*
+         CALL SLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
+         TEMP = ONE / SQRT( SDOT( N, XM, 1, XM, 1 ) )
+         CALL SSCAL( N, TEMP, XM, 1 )
+         CALL SCOPY( N, XM, 1, XP, 1 )
+         CALL SAXPY( N, ONE, RHS, 1, XP, 1 )
+         CALL SAXPY( N, -ONE, XM, 1, RHS, 1 )
+         CALL SGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
+         CALL SGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
+         IF( SASUM( N, XP, 1 ).GT.SASUM( N, RHS, 1 ) )
+     $      CALL SCOPY( N, XP, 1, RHS, 1 )
+*
+*        Compute the sum of squares
+*
+         CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+      END IF
+*
+      RETURN
+*
+*     End of SLATDF
+*
+      END
diff --git a/SRC/slatps.f b/SRC/slatps.f
new file mode 100644
index 00000000..278074d0
--- /dev/null
+++ b/SRC/slatps.f
@@ -0,0 +1,712 @@
+      SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, 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, N
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), CNORM( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLATPS solves one of the triangular systems
+*
+*     A *x = s*b  or  A'*x = s*b
+*
+*  with scaling to prevent overflow, where A is an upper or lower
+*  triangular matrix stored in packed form.  Here 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
+*  STPSV 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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  X       (input/output) REAL 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) REAL
+*          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) REAL 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, STPSV
+*  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 STPSV 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 STPSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
+      REAL               BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SASUM, SDOT, SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SASUM, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SSCAL, STPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLATPS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            IP = 1
+            DO 10 J = 1, N
+               CNORM( J ) = SASUM( J-1, AP( IP ), 1 )
+               IP = IP + J
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            IP = 1
+            DO 20 J = 1, N - 1
+               CNORM( J ) = SASUM( N-J, AP( IP+1 ), 1 )
+               IP = IP + N - J + 1
+   20       CONTINUE
+            CNORM( N ) = ZERO
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM.
+*
+      IMAX = ISAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = ONE / ( SMLNUM*TMAX )
+         CALL SSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine STPSV can be used.
+*
+      J = ISAMAX( N, X, 1 )
+      XMAX = ABS( X( J ) )
+      XBND = XMAX
+      IF( NOTRAN ) THEN
+*
+*        Compute the growth in A * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 50
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = N
+            DO 30 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              M(j) = G(j-1) / abs(A(j,j))
+*
+               TJJ = ABS( AP( IP ) )
+               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+               ELSE
+*
+*                 G(j) could overflow, set GROW to 0.
+*
+                  GROW = ZERO
+               END IF
+               IP = IP + JINC*JLEN
+               JLEN = JLEN - 1
+   30       CONTINUE
+            GROW = XBND
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+   40       CONTINUE
+         END IF
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute the growth in A' * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 80
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, M(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            DO 60 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+               XJ = ONE + CNORM( J )
+               GROW = MIN( GROW, XBND / XJ )
+*
+*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+               TJJ = ABS( AP( IP ) )
+               IF( XJ.GT.TJJ )
+     $            XBND = XBND*( TJJ / XJ )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+   60       CONTINUE
+            GROW = MIN( GROW, XBND )
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 70 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+               XJ = ONE + CNORM( J )
+               GROW = GROW / XJ
+   70       CONTINUE
+         END IF
+   80    CONTINUE
+      END IF
+*
+      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+*        Use the Level 2 BLAS solve if the reciprocal of the bound on
+*        elements of X is not too small.
+*
+         CALL STPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
+      ELSE
+*
+*        Use a Level 1 BLAS solve, scaling intermediate results.
+*
+         IF( XMAX.GT.BIGNUM ) THEN
+*
+*           Scale X so that its components are less than or equal to
+*           BIGNUM in absolute value.
+*
+            SCALE = BIGNUM / XMAX
+            CALL SSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            DO 100 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = ABS( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = AP( IP )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 95
+               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 SSCAL( 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 SSCAL( 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
+   95          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 SSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL SSCAL( 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 SAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
+     $                           1 )
+                     I = ISAMAX( J-1, X, 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+                  IP = IP - J
+               ELSE
+                  IF( J.LT.N ) THEN
+*
+*                    Compute the update
+*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+                     CALL SAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + ISAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+                  IP = IP + N - J + 1
+               END IF
+  100       CONTINUE
+*
+         ELSE
+*
+*           Solve A' * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            DO 140 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = ABS( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = AP( IP )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                     TJJ = ABS( TJJS )
+                     IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                        REC = MIN( ONE, REC*TJJ )
+                        USCAL = USCAL / TJJS
+                     END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL SSCAL( 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 SDOT to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     SUMJ = SDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     SUMJ = SDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 110 I = 1, J - 1
+                        SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
+  110                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 120 I = 1, N - J
+                        SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
+  120                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.TSCAL ) THEN
+*
+*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - SUMJ
+                  XJ = ABS( X( J ) )
+                  IF( NOUNIT ) THEN
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AP( IP )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 135
+                  END IF
+                     TJJ = ABS( TJJS )
+                     IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                        IF( TJJ.LT.ONE ) THEN
+                           IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                              REC = ONE / XJ
+                              CALL SSCAL( 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 SSCAL( 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 130 I = 1, N
+                           X( I ) = ZERO
+  130                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  135             CONTINUE
+               ELSE
+*
+*                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
+*                 product has already been divided by 1/A(j,j).
+*
+                  X( J ) = X( J ) / TJJS - SUMJ
+               END IF
+               XMAX = MAX( XMAX, ABS( X( J ) ) )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+  140       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of SLATPS
+*
+      END
diff --git a/SRC/slatrd.f b/SRC/slatrd.f
new file mode 100644
index 00000000..befc85f9
--- /dev/null
+++ b/SRC/slatrd.f
@@ -0,0 +1,258 @@
+      SUBROUTINE SLATRD( 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 ..
+      REAL               A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLATRD 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', SLATRD reduces the last NB rows and columns of a
+*  matrix, of which the upper triangle is supplied;
+*  if UPLO = 'L', SLATRD reduces the first NB rows and columns of a
+*  matrix, of which the lower triangle is supplied.
+*
+*  This is an auxiliary routine called by SSYTRD.
+*
+*  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) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE, HALF
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IW
+      REAL               ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SGEMV, SLARFG, SSCAL, SSYMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. 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 SGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
+               CALL SGEMV( '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 SLARFG( 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 SSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
+     $                     ZERO, W( 1, IW ), 1 )
+               IF( I.LT.N ) THEN
+                  CALL SGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
+     $                        LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+                  CALL SGEMV( 'No transpose', I-1, N-I, -ONE,
+     $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
+     $                        W( 1, IW ), 1 )
+                  CALL SGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                        LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+                  CALL SGEMV( '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 SSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
+               ALPHA = -HALF*TAU( I-1 )*SDOT( I-1, W( 1, IW ), 1,
+     $                 A( 1, I ), 1 )
+               CALL SAXPY( 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 SGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
+            CALL SGEMV( '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 SLARFG( 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 SSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
+     $                     A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+               CALL SGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
+     $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL SSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
+               ALPHA = -HALF*TAU( I )*SDOT( N-I, W( I+1, I ), 1,
+     $                 A( I+1, I ), 1 )
+               CALL SAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
+            END IF
+*
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SLATRD
+*
+      END
diff --git a/SRC/slatrs.f b/SRC/slatrs.f
new file mode 100644
index 00000000..c065ae29
--- /dev/null
+++ b/SRC/slatrs.f
@@ -0,0 +1,701 @@
+      SUBROUTINE SLATRS( 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
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), CNORM( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLATRS 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 STRSV 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) REAL 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) REAL 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) REAL
+*          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) REAL 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, STRSV
+*  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 STRSV 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 STRSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
+      REAL               BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SASUM, SDOT, SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SASUM, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SSCAL, STRSV, 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( 'SLATRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( '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 ) = SASUM( J-1, A( 1, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N - 1
+               CNORM( J ) = SASUM( 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 = ISAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = ONE / ( SMLNUM*TMAX )
+         CALL SSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine STRSV can be used.
+*
+      J = ISAMAX( 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 STRSV( 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 SSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            DO 100 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 95
+               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 SSCAL( 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 SSCAL( 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
+   95          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 SSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL SSCAL( 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 SAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
+     $                           1 )
+                     I = ISAMAX( 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 SAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + ISAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+               END IF
+  100       CONTINUE
+*
+         ELSE
+*
+*           Solve A' * x = b
+*
+            DO 140 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 SSCAL( 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 SDOT to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     SUMJ = SDOT( J-1, A( 1, J ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     SUMJ = SDOT( 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 110 I = 1, J - 1
+                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+  110                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 120 I = J + 1, N
+                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+  120                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 135
+                  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 SSCAL( 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 SSCAL( 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 130 I = 1, N
+                           X( I ) = ZERO
+  130                   CONTINUE
+                        X( J ) = ONE
+                        SCALE = ZERO
+                        XMAX = ZERO
+                     END IF
+  135             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 ) ) )
+  140       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of SLATRS
+*
+      END
diff --git a/SRC/slatrz.f b/SRC/slatrz.f
new file mode 100644
index 00000000..41f23830
--- /dev/null
+++ b/SRC/slatrz.f
@@ -0,0 +1,127 @@
+      SUBROUTINE SLATRZ( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLATRZ 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) REAL 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) REAL array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFP, SLARZ
+*     ..
+*     .. 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 SLARFP( 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 SLARZ( '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 SLATRZ
+*
+      END
diff --git a/SRC/slatzm.f b/SRC/slatzm.f
new file mode 100644
index 00000000..d3f0f041
--- /dev/null
+++ b/SRC/slatzm.f
@@ -0,0 +1,142 @@
+      SUBROUTINE SLATZM( 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
+      REAL               TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine SORMRZ.
+*
+*  SLATZM applies a Householder matrix generated by STZRQF 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) REAL 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) REAL
+*          The value tau in the representation of P.
+*
+*  C1      (input/output) REAL 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) REAL 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) REAL array, dimension
+*                      (N) if SIDE = 'L'
+*                      (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SGER
+*     ..
+*     .. 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 SCOPY( N, C1, LDC, WORK, 1 )
+         CALL SGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
+     $               WORK, 1 )
+*
+*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
+*        [ C2 ]    [ C2 ]        [ v ]
+*
+         CALL SAXPY( N, -TAU, WORK, 1, C1, LDC )
+         CALL SGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
+*
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        w := C1 + C2 * v
+*
+         CALL SCOPY( M, C1, 1, WORK, 1 )
+         CALL SGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
+     $               WORK, 1 )
+*
+*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
+*
+         CALL SAXPY( M, -TAU, WORK, 1, C1, 1 )
+         CALL SGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
+      END IF
+*
+      RETURN
+*
+*     End of SLATZM
+*
+      END
diff --git a/SRC/slauu2.f b/SRC/slauu2.f
new file mode 100644
index 00000000..569c9464
--- /dev/null
+++ b/SRC/slauu2.f
@@ -0,0 +1,135 @@
+      SUBROUTINE SLAUU2( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAUU2 computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the unblocked form of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SLAUU2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the product U * U'.
+*
+         DO 10 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
+               CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
+            ELSE
+               CALL SSCAL( I, AII, A( 1, I ), 1 )
+            END IF
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product L' * L.
+*
+         DO 20 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = SDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
+               CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+     $                     A( I+1, I ), 1, AII, A( I, 1 ), LDA )
+            ELSE
+               CALL SSCAL( I, AII, A( I, 1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SLAUU2
+*
+      END
diff --git a/SRC/slauum.f b/SRC/slauum.f
new file mode 100644
index 00000000..d3bf1eff
--- /dev/null
+++ b/SRC/slauum.f
@@ -0,0 +1,155 @@
+      SUBROUTINE SLAUUM( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAUUM computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the blocked form of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLAUU2, SSYRK, STRMM, 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( 'SLAUUM', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'SLAUUM', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL SLAUU2( UPLO, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( UPPER ) THEN
+*
+*           Compute the product U * U'.
+*
+            DO 10 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
+     $                     I-1, IB, ONE, A( I, I ), LDA, A( 1, I ),
+     $                     LDA )
+               CALL SLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL SGEMM( 'No transpose', 'Transpose', I-1, IB,
+     $                        N-I-IB+1, ONE, A( 1, I+IB ), LDA,
+     $                        A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
+                  CALL SSYRK( 'Upper', 'No transpose', IB, N-I-IB+1,
+     $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
+     $                        LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute the product L' * L.
+*
+            DO 20 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB,
+     $                     I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
+               CALL SLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL SGEMM( 'Transpose', 'No transpose', IB, I-1,
+     $                        N-I-IB+1, ONE, A( I+IB, I ), LDA,
+     $                        A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
+                  CALL SSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE,
+     $                        A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of SLAUUM
+*
+      END
diff --git a/SRC/slazq3.f b/SRC/slazq3.f
new file mode 100644
index 00000000..8249a8ca
--- /dev/null
+++ b/SRC/slazq3.f
@@ -0,0 +1,302 @@
+      SUBROUTINE SLAZQ3( 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
+      REAL               DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX,
+     $                   SIGMA, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAZQ3 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) REAL array, dimension ( 4*N )
+*         Z holds the qd array.
+*
+*  PP     (input) INTEGER
+*         PP=0 for ping, PP=1 for pong.
+*
+*  DMIN   (output) REAL
+*         Minimum value of d.
+*
+*  SIGMA  (output) REAL
+*         Sum of shifts used in current segment.
+*
+*  DESIG  (input/output) REAL
+*         Lower order part of SIGMA
+*
+*  QMAX   (input) REAL
+*         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 SLASQ5).
+*
+*  TTYPE  (input/output) INTEGER
+*         Shift type.  TTYPE is passed as an argument in order to save
+*         its value between calls to SLAZQ3
+*
+*  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 SLAZQ3
+*
+*  This is a thread safe version of SLASQ3, which passes TTYPE, DMIN1,
+*  DMIN2, DN, DN1. DN2 and TAU through the argument list in place of
+*  declaring them in a SAVE statment.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               CBIAS
+      PARAMETER          ( CBIAS = 1.50E0 )
+      REAL               ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+      PARAMETER          ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
+     $                     ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IPN4, J4, N0IN, NN
+      REAL               EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASQ5, SLASQ6, SLAZQ4
+*     ..
+*     .. External Function ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      N0IN   = N0
+      EPS    = SLAMCH( 'Precision' )
+      SAFMIN = SLAMCH( '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 SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+     $                DN2, TAU, TTYPE, G )
+*
+*        Call dqds until DMIN > 0.
+*
+   80    CONTINUE
+*
+         CALL SLASQ5( 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 SLASQ6( 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 SLAZQ3
+*
+      END
diff --git a/SRC/slazq4.f b/SRC/slazq4.f
new file mode 100644
index 00000000..54c362c0
--- /dev/null
+++ b/SRC/slazq4.f
@@ -0,0 +1,330 @@
+      SUBROUTINE SLAZQ4( 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
+      REAL               DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
+*     ..
+*     .. Array Arguments ..
+      REAL               Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAZQ4 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) REAL 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) REAL
+*        Minimum value of d.
+*
+*  DMIN1 (input) REAL
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (input) REAL
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (input) REAL
+*        d(N)
+*
+*  DN1   (input) REAL
+*        d(N-1)
+*
+*  DN2   (input) REAL
+*        d(N-2)
+*
+*  TAU   (output) REAL
+*        This is the shift.
+*
+*  TTYPE (output) INTEGER
+*        Shift type.
+*
+*  G     (input/output) REAL
+*        G is passed as an argument in order to save its value between
+*        calls to SLAZQ4
+*
+*  Further Details
+*  ===============
+*  CNST1 = 9/16
+*
+*  This is a thread safe version of SLASQ4, which passes G through the
+*  argument list in place of declaring G in a SAVE statment.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               CNST1, CNST2, CNST3
+      PARAMETER          ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
+     $                   CNST3 = 1.050E0 )
+      REAL               QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+      PARAMETER          ( QURTR = 0.250E0, THIRD = 0.3330E0,
+     $                   HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
+     $                   TWO = 2.0E0, HUNDRD = 100.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I4, NN, NP
+      REAL               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 SLAZQ4
+*
+      END
diff --git a/SRC/sopgtr.f b/SRC/sopgtr.f
new file mode 100644
index 00000000..b459808f
--- /dev/null
+++ b/SRC/sopgtr.f
@@ -0,0 +1,160 @@
+      SUBROUTINE SOPGTR( 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 ..
+      REAL               AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SOPGTR 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
+*  SSPTRD 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 SSPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to SSPTRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The vectors which define the elementary reflectors, as
+*          returned by SSPTRD.
+*
+*  TAU     (input) REAL array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SSPTRD.
+*
+*  Q       (output) REAL 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) REAL array, dimension (N-1)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IINFO, IJ, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORG2L, SORG2R, 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( 'SOPGTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to SSPTRD 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 SORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to SSPTRD 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 SORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
+     $                   IINFO )
+         END IF
+      END IF
+      RETURN
+*
+*     End of SOPGTR
+*
+      END
diff --git a/SRC/sopmtr.f b/SRC/sopmtr.f
new file mode 100644
index 00000000..f6779dc3
--- /dev/null
+++ b/SRC/sopmtr.f
@@ -0,0 +1,257 @@
+      SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, 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, UPLO
+      INTEGER            INFO, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SOPMTR overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by SSPTRD using packed
+*  storage:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangular packed storage used in previous
+*                 call to SSPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to SSPTRD.
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension
+*                               (M*(M+1)/2) if SIDE = 'L'
+*                               (N*(N+1)/2) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by SSPTRD.  AP is modified by the routine but
+*          restored on exit.
+*
+*  TAU     (input) REAL array, dimension (M-1) if SIDE = 'L'
+*                                     or (N-1) if SIDE = 'R'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SSPTRD.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORWRD, LEFT, NOTRAN, UPPER
+      INTEGER            I, I1, I2, I3, IC, II, JC, MI, NI, NQ
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SOPMTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to SSPTRD with UPLO = 'U'
+*
+         FORWRD = ( LEFT .AND. NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. .NOT.NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+         ELSE
+            MI = M
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IF( LEFT ) THEN
+*
+*              H(i) is applied to C(1:i,1:n)
+*
+               MI = I
+            ELSE
+*
+*              H(i) is applied to C(1:m,1:i)
+*
+               NI = I
+            END IF
+*
+*           Apply H(i)
+*
+            AII = AP( II )
+            AP( II ) = ONE
+            CALL SLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
+     $                  WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + I + 2
+            ELSE
+               II = II - I - 1
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Q was determined by a call to SSPTRD with UPLO = 'L'.
+*
+         FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         DO 20 I = I1, I2, I3
+            AII = AP( II )
+            AP( II ) = ONE
+            IF( LEFT ) THEN
+*
+*              H(i) is applied to C(i+1:m,1:n)
+*
+               MI = M - I
+               IC = I + 1
+            ELSE
+*
+*              H(i) is applied to C(1:m,i+1:n)
+*
+               NI = N - I
+               JC = I + 1
+            END IF
+*
+*           Apply H(i)
+*
+            CALL SLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
+     $                  C( IC, JC ), LDC, WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + NQ - I + 1
+            ELSE
+               II = II - NQ + I - 2
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of SOPMTR
+*
+      END
diff --git a/SRC/sorg2l.f b/SRC/sorg2l.f
new file mode 100644
index 00000000..e277ffba
--- /dev/null
+++ b/SRC/sorg2l.f
@@ -0,0 +1,127 @@
+      SUBROUTINE SORG2L( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORG2L 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 SGEQLF.
+*
+*  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) REAL 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 SGEQLF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQLF.
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SSCAL, 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( 'SORG2L', -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 SLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+     $               LDA, WORK )
+         CALL SSCAL( 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 SORG2L
+*
+      END
diff --git a/SRC/sorg2r.f b/SRC/sorg2r.f
new file mode 100644
index 00000000..dcb12462
--- /dev/null
+++ b/SRC/sorg2r.f
@@ -0,0 +1,129 @@
+      SUBROUTINE SORG2R( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORG2R 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 SGEQRF.
+*
+*  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) REAL 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 SGEQRF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQRF.
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SSCAL, 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( 'SORG2R', -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 SLARF( '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 SSCAL( 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 SORG2R
+*
+      END
diff --git a/SRC/sorgbr.f b/SRC/sorgbr.f
new file mode 100644
index 00000000..3dd3afc6
--- /dev/null
+++ b/SRC/sorgbr.f
@@ -0,0 +1,244 @@
+      SUBROUTINE SORGBR( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGBR generates one of the real orthogonal matrices Q or P**T
+*  determined by SGEBRD 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 SORGBR returns the first n
+*  columns of Q, where m >= n >= k;
+*  if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR 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 SORGBR 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 SORGBR 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 SGEBRD:
+*          = '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 SGEBRD.
+*          If VECT = 'P', the number of rows in the original K-by-N
+*          matrix reduced by SGEBRD.
+*          K >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by SGEBRD.
+*          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) REAL 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 SGEBRD in its array argument TAUQ or TAUP.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTQ
+      INTEGER            I, IINFO, J, LWKOPT, MN, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORGLQ, SORGQR, 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, 'SORGQR', ' ', M, N, K, -1 )
+         ELSE
+            NB = ILAENV( 1, 'SORGLQ', ' ', M, N, K, -1 )
+         END IF
+         LWKOPT = MAX( 1, MN )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SORGBR', -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 SGEBRD to reduce an m-by-k
+*        matrix
+*
+         IF( M.GE.K ) THEN
+*
+*           If m >= k, assume m >= n >= k
+*
+            CALL SORGQR( 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 SORGQR( 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 SGEBRD to reduce a k-by-n
+*        matrix
+*
+         IF( K.LT.N ) THEN
+*
+*           If k < n, assume k <= m <= n
+*
+            CALL SORGLQ( 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 SORGLQ( 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 SORGBR
+*
+      END
diff --git a/SRC/sorghr.f b/SRC/sorghr.f
new file mode 100644
index 00000000..9f06120f
--- /dev/null
+++ b/SRC/sorghr.f
@@ -0,0 +1,164 @@
+      SUBROUTINE SORGHR( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGHR generates a real orthogonal matrix Q which is defined as the
+*  product of IHI-ILO elementary reflectors of order N, as returned by
+*  SGEHRD:
+*
+*  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 SGEHRD. 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) REAL array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by SGEHRD.
+*          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) REAL array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEHRD.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LWKOPT, NB, NH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORGQR, 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, 'SORGQR', ' ', NH, NH, NH, -1 )
+         LWKOPT = MAX( 1, NH )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SORGHR', -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 SORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
+     $                WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of SORGHR
+*
+      END
diff --git a/SRC/sorgl2.f b/SRC/sorgl2.f
new file mode 100644
index 00000000..5727f0ca
--- /dev/null
+++ b/SRC/sorgl2.f
@@ -0,0 +1,133 @@
+      SUBROUTINE SORGL2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGL2 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 SGELQF.
+*
+*  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) REAL 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 SGELQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGELQF.
+*
+*  WORK    (workspace) REAL array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SSCAL, 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( 'SORGL2', -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 SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     TAU( I ), A( I+1, I ), LDA, WORK )
+            END IF
+            CALL SSCAL( 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 SORGL2
+*
+      END
diff --git a/SRC/sorglq.f b/SRC/sorglq.f
new file mode 100644
index 00000000..0977a3f0
--- /dev/null
+++ b/SRC/sorglq.f
@@ -0,0 +1,215 @@
+      SUBROUTINE SORGLQ( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGLQ 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 SGELQF.
+*
+*  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) REAL 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 SGELQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGELQF.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORGL2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'SORGLQ', ' ', 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( 'SORGLQ', -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, 'SORGLQ', ' ', 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, 'SORGLQ', ' ', 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 SORGL2( 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 SLARFT( '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 SLARFB( '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 SORGL2( 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 SORGLQ
+*
+      END
diff --git a/SRC/sorgql.f b/SRC/sorgql.f
new file mode 100644
index 00000000..ea33ba77
--- /dev/null
+++ b/SRC/sorgql.f
@@ -0,0 +1,222 @@
+      SUBROUTINE SORGQL( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGQL 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 SGEQLF.
+*
+*  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) REAL 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 SGEQLF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQLF.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
+     $                   NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORG2L, 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, 'SORGQL', ' ', 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( 'SORGQL', -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, 'SORGQL', ' ', 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, 'SORGQL', ' ', 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 SORG2L( 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 SLARFT( '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 SLARFB( '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 SORG2L( 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 SORGQL
+*
+      END
diff --git a/SRC/sorgqr.f b/SRC/sorgqr.f
new file mode 100644
index 00000000..1cc1b531
--- /dev/null
+++ b/SRC/sorgqr.f
@@ -0,0 +1,216 @@
+      SUBROUTINE SORGQR( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGQR 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 SGEQRF.
+*
+*  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) REAL 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 SGEQRF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQRF.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORG2R, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'SORGQR', ' ', 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( 'SORGQR', -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, 'SORGQR', ' ', 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, 'SORGQR', ' ', 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 SORG2R( 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 SLARFT( '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 SLARFB( '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 SORG2R( 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 SORGQR
+*
+      END
diff --git a/SRC/sorgr2.f b/SRC/sorgr2.f
new file mode 100644
index 00000000..bf93b4fe
--- /dev/null
+++ b/SRC/sorgr2.f
@@ -0,0 +1,131 @@
+      SUBROUTINE SORGR2( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGR2 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 SGERQF.
+*
+*  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) REAL 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 SGERQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGERQF.
+*
+*  WORK    (workspace) REAL array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, SSCAL, 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( 'SORGR2', -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 SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
+     $               A, LDA, WORK )
+         CALL SSCAL( 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 SORGR2
+*
+      END
diff --git a/SRC/sorgrq.f b/SRC/sorgrq.f
new file mode 100644
index 00000000..1278d8d9
--- /dev/null
+++ b/SRC/sorgrq.f
@@ -0,0 +1,222 @@
+      SUBROUTINE SORGRQ( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGRQ 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 SGERQF.
+*
+*  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) REAL 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 SGERQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGERQF.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORGR2, 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, 'SORGRQ', ' ', 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( 'SORGRQ', -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, 'SORGRQ', ' ', 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, 'SORGRQ', ' ', 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 SORGR2( 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 SLARFT( '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 SLARFB( '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 SORGR2( 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 SORGRQ
+*
+      END
diff --git a/SRC/sorgtr.f b/SRC/sorgtr.f
new file mode 100644
index 00000000..52a43be0
--- /dev/null
+++ b/SRC/sorgtr.f
@@ -0,0 +1,183 @@
+      SUBROUTINE SORGTR( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORGTR generates a real orthogonal matrix Q which is defined as the
+*  product of n-1 elementary reflectors of order N, as returned by
+*  SSYTRD:
+*
+*  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 SSYTRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from SSYTRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by SSYTRD.
+*          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) REAL array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SSYTRD.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, J, LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORGQL, SORGQR, 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, 'SORGQL', ' ', N-1, N-1, N-1, -1 )
+         ELSE
+           NB = ILAENV( 1, 'SORGQR', ' ', 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( 'SORGTR', -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 SSYTRD 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 SORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to SSYTRD 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 SORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                   LWORK, IINFO )
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of SORGTR
+*
+      END
diff --git a/SRC/sorm2l.f b/SRC/sorm2l.f
new file mode 100644
index 00000000..b90743f8
--- /dev/null
+++ b/SRC/sorm2l.f
@@ -0,0 +1,193 @@
+      SUBROUTINE SORM2L( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORM2L 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 SGEQLF. 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) REAL 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
+*          SGEQLF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQLF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, MI, NI, NQ
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, 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( 'SORM2L', -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 SLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
+     $               WORK )
+         A( NQ-K+I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of SORM2L
+*
+      END
diff --git a/SRC/sorm2r.f b/SRC/sorm2r.f
new file mode 100644
index 00000000..be0947cf
--- /dev/null
+++ b/SRC/sorm2r.f
@@ -0,0 +1,197 @@
+      SUBROUTINE SORM2R( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORM2R 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 SGEQRF. 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) REAL 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
+*          SGEQRF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQRF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, 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( 'SORM2R', -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 SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
+     $               LDC, WORK )
+         A( I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of SORM2R
+*
+      END
diff --git a/SRC/sormbr.f b/SRC/sormbr.f
new file mode 100644
index 00000000..2a0052a7
--- /dev/null
+++ b/SRC/sormbr.f
@@ -0,0 +1,282 @@
+      SUBROUTINE SORMBR( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  If VECT = 'Q', SORMBR 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', SORMBR 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 SGEBRD 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 SGEBRD.
+*          If VECT = 'P', the number of rows in the original
+*          matrix reduced by SGEBRD.
+*          K >= 0.
+*
+*  A       (input) REAL 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 SGEBRD.
+*
+*  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) REAL 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 SGEBRD in the array argument TAUQ or TAUP.
+*
+*  C       (input/output) REAL 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) REAL 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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORMLQ, SORMQR, 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, 'SORMQR', SIDE // TRANS, M-1, N, M-1,
+     $                      -1 )
+            ELSE
+               NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1,
+     $                      -1 )
+            END IF   
+         ELSE
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M-1, N, M-1,
+     $                      -1 ) 
+            ELSE
+               NB = ILAENV( 1, 'SORMLQ', 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( 'SORMBR', -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 SGEBRD with nq >= k
+*
+            CALL SORMQR( 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 SGEBRD 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 SORMQR( 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 SGEBRD with nq > k
+*
+            CALL SORMLQ( 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 SGEBRD 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 SORMLQ( 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 SORMBR
+*
+      END
diff --git a/SRC/sormhr.f b/SRC/sormhr.f
new file mode 100644
index 00000000..7d08286a
--- /dev/null
+++ b/SRC/sormhr.f
@@ -0,0 +1,202 @@
+      SUBROUTINE SORMHR( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMHR 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 SGEHRD:
+*
+*  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 SGEHRD. 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) REAL array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by SGEHRD.
+*
+*  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) REAL 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 SGEHRD.
+*
+*  C       (input/output) REAL 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) REAL 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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORMQR, 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, 'SORMQR', SIDE // TRANS, NH, N, NH, -1 )
+         ELSE
+            NB = ILAENV( 1, 'SORMQR', 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( 'SORMHR', -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 SORMQR( 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 SORMHR
+*
+      END
diff --git a/SRC/sorml2.f b/SRC/sorml2.f
new file mode 100644
index 00000000..3ec71cbb
--- /dev/null
+++ b/SRC/sorml2.f
@@ -0,0 +1,197 @@
+      SUBROUTINE SORML2( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORML2 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 SGELQF. 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) REAL 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
+*          SGELQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGELQF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, 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( 'SORML2', -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 SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
+     $               C( IC, JC ), LDC, WORK )
+         A( I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of SORML2
+*
+      END
diff --git a/SRC/sormlq.f b/SRC/sormlq.f
new file mode 100644
index 00000000..b8457b3b
--- /dev/null
+++ b/SRC/sormlq.f
@@ -0,0 +1,268 @@
+      SUBROUTINE SORMLQ( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMLQ 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 SGELQF. 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) REAL 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
+*          SGELQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGELQF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORML2, 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, 'SORMLQ', SIDE // TRANS, M, N, K,
+     $             -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF 
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SORMLQ', -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, 'SORMLQ', 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 SORML2( 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 SLARFT( '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 SLARFB( 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 SORMLQ
+*
+      END
diff --git a/SRC/sormql.f b/SRC/sormql.f
new file mode 100644
index 00000000..48b884df
--- /dev/null
+++ b/SRC/sormql.f
@@ -0,0 +1,263 @@
+      SUBROUTINE SORMQL( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMQL 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 SGEQLF. 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) REAL 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
+*          SGEQLF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQLF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORM2L, 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, 'SORMQL', 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( 'SORMQL', -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, 'SORMQL', 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 SORM2L( 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 SLARFT( '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 SLARFB( 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 SORMQL
+*
+      END
diff --git a/SRC/sormqr.f b/SRC/sormqr.f
new file mode 100644
index 00000000..a5df0ce0
--- /dev/null
+++ b/SRC/sormqr.f
@@ -0,0 +1,261 @@
+      SUBROUTINE SORMQR( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMQR 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 SGEQRF. 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) REAL 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
+*          SGEQRF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGEQRF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORM2R, 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, 'SORMQR', SIDE // TRANS, M, N, K,
+     $        -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SORMQR', -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, 'SORMQR', 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 SORM2R( 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 SLARFT( '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 SLARFB( 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 SORMQR
+*
+      END
diff --git a/SRC/sormr2.f b/SRC/sormr2.f
new file mode 100644
index 00000000..ea894e41
--- /dev/null
+++ b/SRC/sormr2.f
@@ -0,0 +1,193 @@
+      SUBROUTINE SORMR2( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMR2 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 SGERQF. 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) REAL 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
+*          SGERQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGERQF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, MI, NI, NQ
+      REAL               AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARF, 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( 'SORMR2', -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 SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
+     $               WORK )
+         A( I, NQ-K+I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of SORMR2
+*
+      END
diff --git a/SRC/sormr3.f b/SRC/sormr3.f
new file mode 100644
index 00000000..fd1cfbf0
--- /dev/null
+++ b/SRC/sormr3.f
@@ -0,0 +1,206 @@
+      SUBROUTINE SORMR3( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMR3 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 STZRZF. 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) REAL 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
+*          STZRZF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by STZRZF.
+*
+*  C       (input/output) REAL 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) REAL 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           SLARZ, 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( 'SORMR3', -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 SLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ),
+     $               C( IC, JC ), LDC, WORK )
+*
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of SORMR3
+*
+      END
diff --git a/SRC/sormrq.f b/SRC/sormrq.f
new file mode 100644
index 00000000..9ba2a0b7
--- /dev/null
+++ b/SRC/sormrq.f
@@ -0,0 +1,269 @@
+      SUBROUTINE SORMRQ( 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 ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMRQ 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 SGERQF. 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) REAL 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
+*          SGERQF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by SGERQF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARFB, SLARFT, SORMR2, 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, 'SORMRQ', 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( 'SORMRQ', -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, 'SORMRQ', 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 SORMR2( 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 SLARFT( '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 SLARFB( 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 SORMRQ
+*
+      END
diff --git a/SRC/sormrz.f b/SRC/sormrz.f
new file mode 100644
index 00000000..4a29bedd
--- /dev/null
+++ b/SRC/sormrz.f
@@ -0,0 +1,292 @@
+      SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, L, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMRZ 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 STZRZF. 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) REAL 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
+*          STZRZF 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) REAL array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by STZRZF.
+*
+*  C       (input/output) REAL 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) REAL 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 ..
+      REAL               T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARZB, SLARZT, SORMR3, 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
+         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, 'SORMRQ', 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( 'SORMRZ', -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, 'SORMRQ', 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 SORMR3( 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 SLARZT( '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 SLARZB( 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 SORMRZ
+*
+      END
diff --git a/SRC/sormtr.f b/SRC/sormtr.f
new file mode 100644
index 00000000..737914ab
--- /dev/null
+++ b/SRC/sormtr.f
@@ -0,0 +1,223 @@
+      SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, 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, UPLO
+      INTEGER            INFO, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SORMTR overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by SSYTRD:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangle of A contains elementary reflectors
+*                 from SSYTRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from SSYTRD.
+*
+*  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.
+*
+*  A       (input) REAL array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by SSYTRD.
+*
+*  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) REAL 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 SSYTRD.
+*
+*  C       (input/output) REAL 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) REAL 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, UPPER
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SORMQL, SORMQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( UPPER ) THEN
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'SORMQL', SIDE // TRANS, M-1, N, M-1,
+     $                      -1 )
+            ELSE
+               NB = ILAENV( 1, 'SORMQL', SIDE // TRANS, M, N-1, N-1,
+     $                      -1 )
+            END IF
+         ELSE
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M-1, N, M-1,
+     $                      -1 )
+            ELSE
+               NB = ILAENV( 1, 'SORMQR', 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( 'SORMTR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( LEFT ) THEN
+         MI = M - 1
+         NI = N
+      ELSE
+         MI = M
+         NI = N - 1
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to SSYTRD with UPLO = 'U'
+*
+         CALL SORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
+     $                LDC, WORK, LWORK, IINFO )
+      ELSE
+*
+*        Q was determined by a call to SSYTRD with UPLO = 'L'
+*
+         IF( LEFT ) THEN
+            I1 = 2
+            I2 = 1
+         ELSE
+            I1 = 1
+            I2 = 2
+         END IF
+         CALL SORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+     $                C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of SORMTR
+*
+      END
diff --git a/SRC/spbcon.f b/SRC/spbcon.f
new file mode 100644
index 00000000..be1de06a
--- /dev/null
+++ b/SRC/spbcon.f
@@ -0,0 +1,192 @@
+      SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite band matrix using the
+*  Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
+*
+*  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 triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  ANORM   (input) REAL
+*          The 1-norm (or infinity-norm) of the symmetric band matrix A.
+*
+*  RCOND   (output) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      REAL               AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATBS, SRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL SLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+     $                   INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL SLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+     $                   INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL SLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+     $                   INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL SLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+     $                   INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = ISAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL SRSCL( 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 SPBCON
+*
+      END
diff --git a/SRC/spbequ.f b/SRC/spbequ.f
new file mode 100644
index 00000000..fe8101df
--- /dev/null
+++ b/SRC/spbequ.f
@@ -0,0 +1,166 @@
+      SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBEQU computes row and column scalings intended to equilibrate a
+*  symmetric positive definite band matrix A and reduce its condition
+*  number (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular of A is stored;
+*          = 'L':  Lower triangular of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB     (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  S       (output) REAL array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) REAL
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  AMAX    (output) REAL
+*          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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, J
+      REAL               SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+         J = KD + 1
+      ELSE
+         J = 1
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = AB( J, 1 )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      DO 10 I = 2, N
+         S( I ) = AB( J, I )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of SPBEQU
+*
+      END
diff --git a/SRC/spbrfs.f b/SRC/spbrfs.f
new file mode 100644
index 00000000..145a9149
--- /dev/null
+++ b/SRC/spbrfs.f
@@ -0,0 +1,341 @@
+      SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite
+*  and banded, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  AFB     (input) REAL array, dimension (LDAFB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T of the band matrix A as computed by
+*          SPBTRF, in the same storage format as A (see AB).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SPBTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, L, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, SPBTRS, SSBMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( N+1, 2*KD+2 )
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               L = KD + 1 - K
+               DO 40 I = MAX( 1, K-KD ), K - 1
+                  WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+                  S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
+               L = 1 - K
+               DO 60 I = K + 1, MIN( N, K+KD )
+                  WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+                  S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+     $                   INFO )
+            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( N+I )*WORK( I )
+  120          CONTINUE
+               CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of SPBRFS
+*
+      END
diff --git a/SRC/spbstf.f b/SRC/spbstf.f
new file mode 100644
index 00000000..8bd6936b
--- /dev/null
+++ b/SRC/spbstf.f
@@ -0,0 +1,250 @@
+      SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBSTF computes a split Cholesky factorization of a real
+*  symmetric positive definite band matrix A.
+*
+*  This routine is designed to be used in conjunction with SSBGST.
+*
+*  The factorization has the form  A = S**T*S  where S is a band matrix
+*  of the same bandwidth as A and the following structure:
+*
+*    S = ( U    )
+*        ( M  L )
+*
+*  where U is upper triangular of order m = (n+kd)/2, and L is lower
+*  triangular of order n-m.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first kd+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the factor S from the split Cholesky
+*          factorization A = S**T*S. See Further Details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, the factorization could not be completed,
+*               because the updated element a(i,i) was negative; the
+*               matrix A is not positive definite.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 7, KD = 2:
+*
+*  S = ( s11  s12  s13                     )
+*      (      s22  s23  s24                )
+*      (           s33  s34                )
+*      (                s44                )
+*      (           s53  s54  s55           )
+*      (                s64  s65  s66      )
+*      (                     s75  s76  s77 )
+*
+*  If UPLO = 'U', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53  s64  s75
+*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*
+*  If UPLO = 'L', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*  a21  a32  a43  a54  a65  a76   *   s12  s23  s34  s54  s65  s76   *
+*  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KM, M
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSYR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBSTF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+*     Set the splitting point m.
+*
+      M = ( N+KD ) / 2
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+         DO 10 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( KD+1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th column and update the
+*           the leading submatrix within the band.
+*
+            CALL SSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
+            CALL SSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
+     $                 AB( KD+1, J-KM ), KLD )
+   10    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+         DO 20 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( KD+1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL SSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL SSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+         DO 30 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( 1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            CALL SSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
+            CALL SSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
+     $                 AB( 1, J-KM ), KLD )
+   30    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+         DO 40 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = AB( 1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 50
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th column and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL SSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
+               CALL SSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+   50 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of SPBSTF
+*
+      END
diff --git a/SRC/spbsv.f b/SRC/spbsv.f
new file mode 100644
index 00000000..58d977e2
--- /dev/null
+++ b/SRC/spbsv.f
@@ -0,0 +1,151 @@
+      SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**T * U,  if UPLO = 'U', or
+*     A = L * L**T,  if UPLO = 'L',
+*  where U is an upper triangular band matrix, and L is a lower
+*  triangular band matrix, with the same number of superdiagonals or
+*  subdiagonals as A.  The factored form of A is then used to solve the
+*  system of equations A * X = B.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**T*U or A = L*L**T of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) REAL 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPBTRF, SPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of SPBSV
+*
+      END
diff --git a/SRC/spbsvx.f b/SRC/spbsvx.f
new file mode 100644
index 00000000..22d4927d
--- /dev/null
+++ b/SRC/spbsvx.f
@@ -0,0 +1,422 @@
+      SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), S( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+*  compute the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**T * U,  if UPLO = 'U', or
+*        A = L * L**T,  if UPLO = 'L',
+*     where U is an upper triangular band matrix, and L is a lower
+*     triangular band matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFB contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AB and AFB will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right-hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array, except
+*          if FACT = 'F' and EQUED = 'Y', then A must contain the
+*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A
+*          is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  AFB     (input or output) REAL array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the band matrix
+*          A, in the same storage format as A (see AB).  If EQUED = 'Y',
+*          then AFB is the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the equilibrated
+*          matrix A (see the description of A for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) REAL array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          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) REAL 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) REAL 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) REAL 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  Two-dimensional storage of the symmetric matrix A:
+*
+*     a11  a12  a13
+*          a22  a23  a24
+*               a33  a34  a35
+*                    a44  a45  a46
+*                         a55  a56
+*     (aij=conjg(aji))         a66
+*
+*  Band storage of the upper triangle of A:
+*
+*      *    *   a13  a24  a35  a46
+*      *   a12  a23  a34  a45  a56
+*     a11  a22  a33  a44  a55  a66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*     a11  a22  a33  a44  a55  a66
+*     a21  a32  a43  a54  a65   *
+*     a31  a42  a53  a64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU, UPPER
+      INTEGER            I, INFEQU, J, J1, J2
+      REAL               AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSB
+      EXTERNAL           LSAME, SLAMCH, SLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SLAQSB, SPBCON, SPBEQU, SPBRFS,
+     $                   SPBTRF, SPBTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -9
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -10
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -11
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -13
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -15
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         IF( UPPER ) THEN
+            DO 40 J = 1, N
+               J1 = MAX( J-KD, 1 )
+               CALL SCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
+     $                     AFB( KD+1-J+J1, J ), 1 )
+   40       CONTINUE
+         ELSE
+            DO 50 J = 1, N
+               J2 = MIN( J+KD, N )
+               CALL SCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
+   50       CONTINUE
+         END IF
+*
+         CALL SPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = SLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK,
+     $             INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 70 J = 1, NRHS
+            DO 60 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   60       CONTINUE
+   70    CONTINUE
+         DO 80 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   80    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of SPBSVX
+*
+      END
diff --git a/SRC/spbtf2.f b/SRC/spbtf2.f
new file mode 100644
index 00000000..a5c223c3
--- /dev/null
+++ b/SRC/spbtf2.f
@@ -0,0 +1,194 @@
+      SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBTF2 computes the Cholesky factorization of a real symmetric
+*  positive definite band 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, U' is the transpose of U, 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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KN
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSYR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         DO 10 J = 1, N
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AB( KD+1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 30
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of row J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL SSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL SSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Compute the Cholesky factorization A = L*L'.
+*
+         DO 20 J = 1, N
+*
+*           Compute L(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AB( 1, J )
+            IF( AJJ.LE.ZERO )
+     $         GO TO 30
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of column J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL SSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
+               CALL SSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+   30 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of SPBTF2
+*
+      END
diff --git a/SRC/spbtrf.f b/SRC/spbtrf.f
new file mode 100644
index 00000000..a50f6632
--- /dev/null
+++ b/SRC/spbtrf.f
@@ -0,0 +1,364 @@
+      SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBTRF computes the Cholesky factorization of a real symmetric
+*  positive definite band matrix A.
+*
+*  The factorization has the form
+*     A = U**T * U,  if UPLO = 'U', or
+*     A = L  * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**T*U or A = L*L**T of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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 band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  Contributed by
+*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, IB, II, J, JJ, NB
+*     ..
+*     .. Local Arrays ..
+      REAL               WORK( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SPBTF2, SPOTF2, SSYRK, STRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
+     $    ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment
+*
+      NB = ILAENV( 1, 'SPBTRF', UPLO, N, KD, -1, -1 )
+*
+*     The block size must not exceed the semi-bandwidth KD, and must not
+*     exceed the limit set by the size of the local array WORK.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KD ) THEN
+*
+*        Use unblocked code
+*
+         CALL SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Compute the Cholesky factorization of a symmetric band
+*           matrix, given the upper triangle of the matrix in band
+*           storage.
+*
+*           Zero the upper triangle of the work array.
+*
+            DO 20 J = 1, NB
+               DO 10 I = 1, J - 1
+                  WORK( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 70 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL SPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11   A12   A13
+*                          A22   A23
+*                                A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A12, A22 and
+*                 A23 are empty if IB = KD. The upper triangle of A13
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A12
+*
+                     CALL STRSM( 'Left', 'Upper', 'Transpose',
+     $                           'Non-unit', IB, I2, ONE, AB( KD+1, I ),
+     $                           LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL SSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
+     $                           AB( KD+1-IB, I+IB ), LDAB-1, ONE,
+     $                           AB( KD+1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the lower triangle of A13 into the work array.
+*
+                     DO 40 JJ = 1, I3
+                        DO 30 II = JJ, IB
+                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
+   30                   CONTINUE
+   40                CONTINUE
+*
+*                    Update A13 (in the work array).
+*
+                     CALL STRSM( 'Left', 'Upper', 'Transpose',
+     $                           'Non-unit', IB, I3, ONE, AB( KD+1, I ),
+     $                           LDAB-1, WORK, LDWORK )
+*
+*                    Update A23
+*
+                     IF( I2.GT.0 )
+     $                  CALL SGEMM( 'Transpose', 'No Transpose', I2, I3,
+     $                              IB, -ONE, AB( KD+1-IB, I+IB ),
+     $                              LDAB-1, WORK, LDWORK, ONE,
+     $                              AB( 1+IB, I+KD ), LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL SSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
+     $                           WORK, LDWORK, ONE, AB( KD+1, I+KD ),
+     $                           LDAB-1 )
+*
+*                    Copy the lower triangle of A13 back into place.
+*
+                     DO 60 JJ = 1, I3
+                        DO 50 II = JJ, IB
+                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
+   50                   CONTINUE
+   60                CONTINUE
+                  END IF
+               END IF
+   70       CONTINUE
+         ELSE
+*
+*           Compute the Cholesky factorization of a symmetric band
+*           matrix, given the lower triangle of the matrix in band
+*           storage.
+*
+*           Zero the lower triangle of the work array.
+*
+            DO 90 J = 1, NB
+               DO 80 I = J + 1, NB
+                  WORK( I, J ) = ZERO
+   80          CONTINUE
+   90       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 140 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL SPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11
+*                    A21   A22
+*                    A31   A32   A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A21, A22 and
+*                 A32 are empty if IB = KD. The lower triangle of A31
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A21
+*
+                     CALL STRSM( 'Right', 'Lower', 'Transpose',
+     $                           'Non-unit', I2, IB, ONE, AB( 1, I ),
+     $                           LDAB-1, AB( 1+IB, I ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL SSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
+     $                           AB( 1+IB, I ), LDAB-1, ONE,
+     $                           AB( 1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the upper triangle of A31 into the work array.
+*
+                     DO 110 JJ = 1, IB
+                        DO 100 II = 1, MIN( JJ, I3 )
+                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
+  100                   CONTINUE
+  110                CONTINUE
+*
+*                    Update A31 (in the work array).
+*
+                     CALL STRSM( 'Right', 'Lower', 'Transpose',
+     $                           'Non-unit', I3, IB, ONE, AB( 1, I ),
+     $                           LDAB-1, WORK, LDWORK )
+*
+*                    Update A32
+*
+                     IF( I2.GT.0 )
+     $                  CALL SGEMM( 'No transpose', 'Transpose', I3, I2,
+     $                              IB, -ONE, WORK, LDWORK,
+     $                              AB( 1+IB, I ), LDAB-1, ONE,
+     $                              AB( 1+KD-IB, I+IB ), LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL SSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
+     $                           WORK, LDWORK, ONE, AB( 1, I+KD ),
+     $                           LDAB-1 )
+*
+*                    Copy the upper triangle of A31 back into place.
+*
+                     DO 130 JJ = 1, IB
+                        DO 120 II = 1, MIN( JJ, I3 )
+                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
+  120                   CONTINUE
+  130                CONTINUE
+                  END IF
+               END IF
+  140       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+  150 CONTINUE
+      RETURN
+*
+*     End of SPBTRF
+*
+      END
diff --git a/SRC/spbtrs.f b/SRC/spbtrs.f
new file mode 100644
index 00000000..22384772
--- /dev/null
+++ b/SRC/spbtrs.f
@@ -0,0 +1,145 @@
+      SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPBTRS solves a system of linear equations A*X = B with a symmetric
+*  positive definite band matrix A using the Cholesky factorization
+*  A = U**T*U or A = L*L**T computed by SPBTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) REAL 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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPBTRS', -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.
+*
+         DO 10 J = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 J = 1, NRHS
+*
+*           Solve L*X = B, overwriting B with X.
+*
+            CALL STBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+*
+*           Solve L'*X = B, overwriting B with X.
+*
+            CALL STBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SPBTRS
+*
+      END
diff --git a/SRC/spocon.f b/SRC/spocon.f
new file mode 100644
index 00000000..dacba229
--- /dev/null
+++ b/SRC/spocon.f
@@ -0,0 +1,177 @@
+      SUBROUTINE SPOCON( 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOCON 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 SPOTRF.
+*
+*  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) REAL 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 SPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) REAL
+*          The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+*  RCOND   (output) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      REAL               AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATRS, SRSCL, 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( 'SPOCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of inv(A).
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL SLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+     $                   LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL SLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL SLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL SLATRS( '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 = ISAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL SRSCL( 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 SPOCON
+*
+      END
diff --git a/SRC/spoequ.f b/SRC/spoequ.f
new file mode 100644
index 00000000..6ee0fc0c
--- /dev/null
+++ b/SRC/spoequ.f
@@ -0,0 +1,136 @@
+      SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, N
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOEQU computes row and column scalings intended to equilibrate a
+*  symmetric positive definite matrix A and reduce its condition number
+*  (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) REAL array, dimension (LDA,N)
+*          The N-by-N symmetric positive definite matrix whose scaling
+*          factors are to be computed.  Only the diagonal elements of A
+*          are referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  S       (output) REAL array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) REAL
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  AMAX    (output) REAL
+*          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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               SMIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPOEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      S( 1 ) = A( 1, 1 )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+      DO 10 I = 2, N
+         S( I ) = A( I, I )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of SPOEQU
+*
+      END
diff --git a/SRC/sporfs.f b/SRC/sporfs.f
new file mode 100644
index 00000000..5b3577f4
--- /dev/null
+++ b/SRC/sporfs.f
@@ -0,0 +1,331 @@
+      SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPORFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite,
+*  and provides error bounds and backward error estimates for the
+*  solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) REAL 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(1,N).
+*
+*  AF      (input) REAL array, dimension (LDAF,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, as computed by SPOTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SPOTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, SPOTRS, SSYMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPORFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of SPORFS
+*
+      END
diff --git a/SRC/sposv.f b/SRC/sposv.f
new file mode 100644
index 00000000..8247741e
--- /dev/null
+++ b/SRC/sposv.f
@@ -0,0 +1,121 @@
+      SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, 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, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**T* U,  if UPLO = 'U', or
+*     A = L * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is a lower triangular
+*  matrix.  The factored form of A is then used to solve the system of
+*  equations A * X = B.
+*
+*  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) REAL 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).
+*
+*  B       (input/output) REAL 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPOTRF, SPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPOSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL SPOTRF( UPLO, N, A, LDA, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of SPOSV
+*
+      END
diff --git a/SRC/sposvx.f b/SRC/sposvx.f
new file mode 100644
index 00000000..9fb1e0bc
--- /dev/null
+++ b/SRC/sposvx.f
@@ -0,0 +1,377 @@
+      SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
+     $                   S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), S( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+*  compute the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**T* U,  if UPLO = 'U', or
+*        A = L * L**T,  if UPLO = 'L',
+*     where U is an upper triangular matrix and L is a lower triangular
+*     matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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 contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  A and AF will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the symmetric matrix A, except if FACT = 'F' and
+*          EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input or output) REAL array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, in the same storage
+*          format as A.  If EQUED .ne. 'N', then AF is the factored form
+*          of the equilibrated matrix diag(S)*A*diag(S).
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the original
+*          matrix A.
+*
+*          If FACT = 'E', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T of the equilibrated
+*          matrix A (see the description of A for the form of the
+*          equilibrated matrix).
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) REAL array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          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) REAL 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) REAL 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) REAL 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
+*          > 0: if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      REAL               AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSY
+      EXTERNAL           LSAME, SLAMCH, SLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACPY, SLAQSY, SPOCON, SPOEQU, SPORFS, SPOTRF,
+     $                   SPOTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -9
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -10
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -14
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPOSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL SPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL SPOTRF( UPLO, N, AF, LDAF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = SLANSY( '1', UPLO, N, A, LDA, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
+     $             FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of SPOSVX
+*
+      END
diff --git a/SRC/spotf2.f b/SRC/spotf2.f
new file mode 100644
index 00000000..247ccb0e
--- /dev/null
+++ b/SRC/spotf2.f
@@ -0,0 +1,167 @@
+      SUBROUTINE SPOTF2( 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 ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOTF2 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SSCAL, 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( 'SPOTF2', -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 ) - SDOT( 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 SGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
+     $                     LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
+               CALL SSCAL( 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 ) - SDOT( 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 SGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
+     $                     LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
+               CALL SSCAL( 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 SPOTF2
+*
+      END
diff --git a/SRC/spotrf.f b/SRC/spotrf.f
new file mode 100644
index 00000000..396fdb07
--- /dev/null
+++ b/SRC/spotrf.f
@@ -0,0 +1,183 @@
+      SUBROUTINE SPOTRF( 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 ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOTRF 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SPOTF2, SSYRK, STRSM, 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( 'SPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'SPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL SPOTF2( 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 SSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
+     $                     A( 1, J ), LDA, ONE, A( J, J ), LDA )
+               CALL SPOTF2( '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 SGEMM( '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 STRSM( '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 SSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
+     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
+               CALL SPOTF2( '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 SGEMM( '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 STRSM( '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 SPOTRF
+*
+      END
diff --git a/SRC/spotri.f b/SRC/spotri.f
new file mode 100644
index 00000000..75fefa22
--- /dev/null
+++ b/SRC/spotri.f
@@ -0,0 +1,96 @@
+      SUBROUTINE SPOTRI( 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 ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOTRI computes the inverse of a real symmetric positive definite
+*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+*  computed by SPOTRF.
+*
+*  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) REAL array, dimension (LDA,N)
+*          On entry, the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, as computed by
+*          SPOTRF.
+*          On exit, the upper or lower triangle of the (symmetric)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  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 (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAUUM, STRTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPOTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL STRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+*     Form inv(U)*inv(U)' or inv(L)'*inv(L).
+*
+      CALL SLAUUM( UPLO, N, A, LDA, INFO )
+*
+      RETURN
+*
+*     End of SPOTRI
+*
+      END
diff --git a/SRC/spotrs.f b/SRC/spotrs.f
new file mode 100644
index 00000000..27d449ce
--- /dev/null
+++ b/SRC/spotrs.f
@@ -0,0 +1,132 @@
+      SUBROUTINE SPOTRS( 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 ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPOTRS 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 SPOTRF.
+*
+*  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) REAL 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 SPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STRSM, 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( 'SPOTRS', -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 STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL STRSM( '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 STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL STRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+      END IF
+*
+      RETURN
+*
+*     End of SPOTRS
+*
+      END
diff --git a/SRC/sppcon.f b/SRC/sppcon.f
new file mode 100644
index 00000000..baccb8ef
--- /dev/null
+++ b/SRC/sppcon.f
@@ -0,0 +1,176 @@
+      SUBROUTINE SPPCON( UPLO, N, AP, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite packed matrix using
+*  the Cholesky factorization A = U**T*U or A = L*L**T computed by
+*  SPPTRF.
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  ANORM   (input) REAL
+*          The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+*  RCOND   (output) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      REAL               AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATPS, SRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPCON', -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 = SLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL SLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL SLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL SLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL SLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = ISAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL SRSCL( 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 SPPCON
+*
+      END
diff --git a/SRC/sppequ.f b/SRC/sppequ.f
new file mode 100644
index 00000000..3f07ac0e
--- /dev/null
+++ b/SRC/sppequ.f
@@ -0,0 +1,168 @@
+      SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, 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
+      REAL               AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPEQU computes row and column scalings intended to equilibrate a
+*  symmetric positive definite matrix A in packed storage and reduce
+*  its condition number (with respect to the two-norm).  S contains the
+*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
+*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
+*  This choice of S puts the condition number of B within a factor N of
+*  the smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  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) REAL 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.
+*
+*  S       (output) REAL array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) REAL
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  AMAX    (output) REAL
+*          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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, JJ
+      REAL               SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = AP( 1 )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+      IF( UPPER ) THEN
+*
+*        UPLO = 'U':  Upper triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 10 I = 2, N
+            JJ = JJ + I
+            S( I ) = AP( JJ )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   10    CONTINUE
+*
+      ELSE
+*
+*        UPLO = 'L':  Lower triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 20 I = 2, N
+            JJ = JJ + N - I + 2
+            S( I ) = AP( JJ )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   20    CONTINUE
+      END IF
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 30 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   30    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 40 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   40    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of SPPEQU
+*
+      END
diff --git a/SRC/spprfs.f b/SRC/spprfs.f
new file mode 100644
index 00000000..16b066ce
--- /dev/null
+++ b/SRC/spprfs.f
@@ -0,0 +1,328 @@
+      SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) REAL 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.
+*
+*  AFP     (input) REAL array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,
+*          packed columnwise in a linear array in the same format as A
+*          (see AP).
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SPPTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, SPPTRS, SSPMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+     $               1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of SPPRFS
+*
+      END
diff --git a/SRC/sppsv.f b/SRC/sppsv.f
new file mode 100644
index 00000000..22331705
--- /dev/null
+++ b/SRC/sppsv.f
@@ -0,0 +1,133 @@
+      SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**T* U,  if UPLO = 'U', or
+*     A = L * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is a lower triangular
+*  matrix.  The factored form of A is then used to solve the system of
+*  equations A * X = B.
+*
+*  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.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.  
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, in the same storage
+*          format as A.
+*
+*  B       (input/output) REAL 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  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 = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPPTRF, SPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL SPPTRF( UPLO, N, AP, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of SPPSV
+*
+      END
diff --git a/SRC/sppsvx.f b/SRC/sppsvx.f
new file mode 100644
index 00000000..1e8c257b
--- /dev/null
+++ b/SRC/sppsvx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, 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, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), S( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+*  compute the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**T* U,  if UPLO = 'U', or
+*        A = L * L**T,  if UPLO = 'L',
+*     where U is an upper triangular matrix and L is a lower triangular
+*     matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFP contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AP and AFP will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array, except if FACT = 'F'
+*          and EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  The j-th column of A is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  AFP     (input or output) REAL array, dimension
+*                            (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U'*U or A = L*L', in the same storage
+*          format as A.  If EQUED .ne. 'N', then AFP is the factored
+*          form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U'*U or A = L*L' of the original matrix A.
+*
+*          If FACT = 'E', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U'*U or A = L*L' of the equilibrated
+*          matrix A (see the description of AP for the form of the
+*          equilibrated matrix).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) REAL array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          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) REAL 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) REAL 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) REAL 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  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 = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      REAL               AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSP
+      EXTERNAL           LSAME, SLAMCH, SLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SLAQSP, SPPCON, SPPEQU, SPPRFS,
+     $                   SPPTRF, SPPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = SLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -7
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -8
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -10
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL SPPTRF( UPLO, N, AFP, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
+     $             WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of SPPSVX
+*
+      END
diff --git a/SRC/spptrf.f b/SRC/spptrf.f
new file mode 100644
index 00000000..cf5e3a21
--- /dev/null
+++ b/SRC/spptrf.f
@@ -0,0 +1,177 @@
+      SUBROUTINE SPPTRF( 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 ..
+      REAL               AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPTRF 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSPR, STPSV, 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( 'SPPTRF', -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 STPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
+     $                     AP( JC ), 1 )
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AP( JJ ) - SDOT( 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 SSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
+               CALL SSPR( '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 SPPTRF
+*
+      END
diff --git a/SRC/spptri.f b/SRC/spptri.f
new file mode 100644
index 00000000..5cb06f26
--- /dev/null
+++ b/SRC/spptri.f
@@ -0,0 +1,128 @@
+      SUBROUTINE SPPTRI( 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 ..
+      REAL               AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPTRI computes the inverse of a real symmetric positive definite
+*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+*  computed by SPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor is stored in AP;
+*          = 'L':  Lower triangular factor is stored in AP.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the triangular factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T, packed columnwise as
+*          a linear array.  The j-th column of U or L is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*          On exit, the upper or lower triangle of the (symmetric)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ, JJN
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSPR, STPMV, STPTRI, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL STPTRI( UPLO, 'Non-unit', N, AP, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the product inv(U) * inv(U)'.
+*
+         JJ = 0
+         DO 10 J = 1, N
+            JC = JJ + 1
+            JJ = JJ + J
+            IF( J.GT.1 )
+     $         CALL SSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
+            AJJ = AP( JJ )
+            CALL SSCAL( J, AJJ, AP( JC ), 1 )
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product inv(L)' * inv(L).
+*
+         JJ = 1
+         DO 20 J = 1, N
+            JJN = JJ + N - J + 1
+            AP( JJ ) = SDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
+            IF( J.LT.N )
+     $         CALL STPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
+     $                     AP( JJN ), AP( JJ+1 ), 1 )
+            JJ = JJN
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SPPTRI
+*
+      END
diff --git a/SRC/spptrs.f b/SRC/spptrs.f
new file mode 100644
index 00000000..c82b9de6
--- /dev/null
+++ b/SRC/spptrs.f
@@ -0,0 +1,134 @@
+      SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPPTRS solves a system of linear equations A*X = B with a symmetric
+*  positive definite matrix A in packed storage using the Cholesky
+*  factorization A = U**T*U or A = L*L**T computed by SPPTRF.
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  B       (input/output) REAL 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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPPTRS', -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.
+*
+         DO 10 I = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL STPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL STPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve L*Y = B, overwriting B with X.
+*
+            CALL STPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+*
+*           Solve L'*X = Y, overwriting B with X.
+*
+            CALL STPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SPPTRS
+*
+      END
diff --git a/SRC/sptcon.f b/SRC/sptcon.f
new file mode 100644
index 00000000..3144bde3
--- /dev/null
+++ b/SRC/sptcon.f
@@ -0,0 +1,149 @@
+      SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTCON computes the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite tridiagonal matrix
+*  using the factorization A = L*D*L**T or A = U**T*D*U computed by
+*  SPTTRF.
+*
+*  Norm(inv(A)) is computed by a direct method, and the reciprocal of
+*  the condition number is computed as
+*               RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization of A, as computed by SPTTRF.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the unit bidiagonal factor
+*          U or L from the factorization of A,  as computed by SPTTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
+*          1-norm of inv(A) computed in this routine.
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The method used is described in Nicholas J. Higham, "Efficient
+*  Algorithms for Computing the Condition Number of a Tridiagonal
+*  Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      REAL               AINVNM
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      EXTERNAL           ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is positive.
+*
+      DO 10 I = 1, N
+         IF( D( I ).LE.ZERO )
+     $      RETURN
+   10 CONTINUE
+*
+*     Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*        m(i,j) =  abs(A(i,j)), i = j,
+*        m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*     and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*     Solve M(L) * x = e.
+*
+      WORK( 1 ) = ONE
+      DO 20 I = 2, N
+         WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
+   20 CONTINUE
+*
+*     Solve D * M(L)' * x = b.
+*
+      WORK( N ) = WORK( N ) / D( N )
+      DO 30 I = N - 1, 1, -1
+         WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
+   30 CONTINUE
+*
+*     Compute AINVNM = max(x(i)), 1<=i<=n.
+*
+      IX = ISAMAX( N, WORK, 1 )
+      AINVNM = ABS( WORK( IX ) )
+*
+*     Compute the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of SPTCON
+*
+      END
diff --git a/SRC/spteqr.f b/SRC/spteqr.f
new file mode 100644
index 00000000..a9cd707b
--- /dev/null
+++ b/SRC/spteqr.f
@@ -0,0 +1,189 @@
+      SUBROUTINE SPTEQR( 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 ..
+      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric positive definite tridiagonal matrix by first factoring the
+*  matrix using SPTTRF, and then calling SBDSQR to compute the singular
+*  values of the bidiagonal factor.
+*
+*  This routine computes the eigenvalues of the positive definite
+*  tridiagonal matrix to high relative accuracy.  This means that if the
+*  eigenvalues range over many orders of magnitude in size, then the
+*  small eigenvalues and corresponding eigenvectors will be computed
+*  more accurately than, for example, with the standard QR method.
+*
+*  The eigenvectors of a full or band symmetric positive definite matrix
+*  can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
+*  reduce this matrix to tridiagonal form. (The reduction to tridiagonal
+*  form, however, may preclude the possibility of obtaining high
+*  relative accuracy in the small eigenvalues of the original matrix, if
+*  these eigenvalues range over many orders of magnitude.)
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'V':  Compute eigenvectors of original symmetric
+*                  matrix also.  Array Z contains the orthogonal
+*                  matrix used to reduce the original matrix to
+*                  tridiagonal form.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal
+*          matrix.
+*          On normal exit, D contains the eigenvalues, in descending
+*          order.
+*
+*  E       (input/output) REAL array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix.
+*          On exit, E has been destroyed.
+*
+*  Z       (input/output) REAL array, dimension (LDZ, N)
+*          On entry, if COMPZ = 'V', the orthogonal matrix used in the
+*          reduction to tridiagonal form.
+*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
+*          original symmetric matrix;
+*          if COMPZ = 'I', the orthonormal eigenvectors of the
+*          tridiagonal matrix.
+*          If INFO > 0 on exit, Z contains the eigenvectors associated
+*          with only the stored eigenvalues.
+*          If  COMPZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          COMPZ = 'V' or 'I', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (4*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 Cholesky factorization of the matrix could
+*                      not be performed because the i-th principal minor
+*                      was not positive definite.
+*                > N   the SVD algorithm failed to converge;
+*                      if INFO = N+i, i off-diagonal elements of the
+*                      bidiagonal factor did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SBDSQR, SLASET, SPTTRF, XERBLA
+*     ..
+*     .. Local Arrays ..
+      REAL               C( 1, 1 ), VT( 1, 1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICOMPZ, NRU
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+     $         N ) ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPTEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.GT.0 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+      IF( ICOMPZ.EQ.2 )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Call SPTTRF to factor the matrix.
+*
+      CALL SPTTRF( N, D, E, INFO )
+      IF( INFO.NE.0 )
+     $   RETURN
+      DO 10 I = 1, N
+         D( I ) = SQRT( D( I ) )
+   10 CONTINUE
+      DO 20 I = 1, N - 1
+         E( I ) = E( I )*D( I )
+   20 CONTINUE
+*
+*     Call SBDSQR to compute the singular values/vectors of the
+*     bidiagonal factor.
+*
+      IF( ICOMPZ.GT.0 ) THEN
+         NRU = N
+      ELSE
+         NRU = 0
+      END IF
+      CALL SBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
+     $             WORK, INFO )
+*
+*     Square the singular values.
+*
+      IF( INFO.EQ.0 ) THEN
+         DO 30 I = 1, N
+            D( I ) = D( I )*D( I )
+   30    CONTINUE
+      ELSE
+         INFO = N + INFO
+      END IF
+*
+      RETURN
+*
+*     End of SPTEQR
+*
+      END
diff --git a/SRC/sptrfs.f b/SRC/sptrfs.f
new file mode 100644
index 00000000..d7241dd5
--- /dev/null
+++ b/SRC/sptrfs.f
@@ -0,0 +1,301 @@
+      SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
+     $                   BERR, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   E( * ), EF( * ), FERR( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric positive definite
+*  and tridiagonal, and provides error bounds and backward error
+*  estimates for the solution.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+*  DF      (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization computed by SPTTRF.
+*
+*  EF      (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the unit bidiagonal factor
+*          L from the factorization computed by SPTTRF.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SPTTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL array, dimension (NRHS)
+*          The forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).
+*
+*  BERR    (output) REAL 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) REAL array, dimension (2*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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            COUNT, I, IX, J, NZ
+      REAL               BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2,
+     $                   SAFMIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SPTTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SLAMCH
+      EXTERNAL           ISAMAX, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 90 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X.  Also compute
+*        abs(A)*abs(x) + abs(b) for use in the backward error bound.
+*
+         IF( N.EQ.1 ) THEN
+            BI = B( 1, J )
+            DX = D( 1 )*X( 1, J )
+            WORK( N+1 ) = BI - DX
+            WORK( 1 ) = ABS( BI ) + ABS( DX )
+         ELSE
+            BI = B( 1, J )
+            DX = D( 1 )*X( 1, J )
+            EX = E( 1 )*X( 2, J )
+            WORK( N+1 ) = BI - DX - EX
+            WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
+            DO 30 I = 2, N - 1
+               BI = B( I, J )
+               CX = E( I-1 )*X( I-1, J )
+               DX = D( I )*X( I, J )
+               EX = E( I )*X( I+1, J )
+               WORK( N+I ) = BI - CX - DX - EX
+               WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
+   30       CONTINUE
+            BI = B( N, J )
+            CX = E( N-1 )*X( N-1, J )
+            DX = D( N )*X( N, J )
+            WORK( N+N ) = BI - CX - DX
+            WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 40 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   40    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
+            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+         DO 50 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   50    CONTINUE
+         IX = ISAMAX( N, WORK, 1 )
+         FERR( J ) = WORK( IX )
+*
+*        Estimate the norm of inv(A).
+*
+*        Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*           m(i,j) =  abs(A(i,j)), i = j,
+*           m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*        and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*        Solve M(L) * x = e.
+*
+         WORK( 1 ) = ONE
+         DO 60 I = 2, N
+            WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
+   60    CONTINUE
+*
+*        Solve D * M(L)' * x = b.
+*
+         WORK( N ) = WORK( N ) / DF( N )
+         DO 70 I = N - 1, 1, -1
+            WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
+   70    CONTINUE
+*
+*        Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
+*
+         IX = ISAMAX( N, WORK, 1 )
+         FERR( J ) = FERR( J )*ABS( WORK( IX ) )
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 80 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+   80    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+   90 CONTINUE
+*
+      RETURN
+*
+*     End of SPTRFS
+*
+      END
diff --git a/SRC/sptsv.f b/SRC/sptsv.f
new file mode 100644
index 00000000..6c3c515a
--- /dev/null
+++ b/SRC/sptsv.f
@@ -0,0 +1,99 @@
+      SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTSV computes the solution to a real system of linear equations
+*  A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
+*  matrix, and X and B are N-by-NRHS matrices.
+*
+*  A is factored as A = L*D*L**T, and the factored form of A is then
+*  used to solve the system of equations.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the factorization A = L*D*L**T.
+*
+*  E       (input/output) REAL array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L**T factorization of
+*          A.  (E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U**T*D*U factorization of A.)
+*
+*  B       (input/output) REAL 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).
+*
+*  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 solution has not been
+*                computed.  The factorization has not been completed
+*                unless i = N.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           SPTTRF, SPTTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPTSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      CALL SPTTRF( N, D, E, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SPTTRS( N, NRHS, D, E, B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of SPTSV
+*
+      END
diff --git a/SRC/sptsvx.f b/SRC/sptsvx.f
new file mode 100644
index 00000000..9c7527b8
--- /dev/null
+++ b/SRC/sptsvx.f
@@ -0,0 +1,233 @@
+      SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), BERR( * ), D( * ), DF( * ),
+     $                   E( * ), EF( * ), FERR( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTSVX uses the factorization A = L*D*L**T to compute the solution
+*  to a real system of linear equations A*X = B, where A is an N-by-N
+*  symmetric positive definite tridiagonal matrix and X and B are
+*  N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
+*     is a unit lower bidiagonal matrix and D is diagonal.  The
+*     factorization can also be regarded as having the form
+*     A = U**T*D*U.
+*
+*  2. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, DF and EF contain the factored form of A.
+*                  D, E, DF, and EF will not be modified.
+*          = 'N':  The matrix A will be copied to DF and EF and
+*                  factored.
+*
+*  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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+*  DF      (input or output) REAL array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**T factorization of A.
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**T factorization of A.
+*
+*  EF      (input or output) REAL array, dimension (N-1)
+*          If FACT = 'F', then EF is an input argument and on entry
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**T factorization of A.
+*          If FACT = 'N', then EF is an output argument and on exit
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**T factorization of A.
+*
+*  B       (input) REAL array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The reciprocal condition number of the matrix A.  If RCOND
+*          is less than the machine precision (in particular, if
+*          RCOND = 0), the matrix is singular to working precision.
+*          This condition is indicated by a return code of INFO > 0.
+*
+*  FERR    (output) REAL array, dimension (NRHS)
+*          The forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).
+*
+*  BERR    (output) REAL 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) REAL 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, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SPTCON, SPTRFS, SPTTRF, SPTTRS,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+         CALL SCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 )
+     $      CALL SCOPY( N-1, E, 1, EF, 1 )
+         CALL SPTTRF( N, DF, EF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = SLANST( '1', N, D, E )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
+     $             WORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of SPTSVX
+*
+      END
diff --git a/SRC/spttrf.f b/SRC/spttrf.f
new file mode 100644
index 00000000..cb3df359
--- /dev/null
+++ b/SRC/spttrf.f
@@ -0,0 +1,152 @@
+      SUBROUTINE SPTTRF( 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 ..
+      REAL               D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTTRF computes the L*D*L' factorization of a real symmetric
+*  positive definite tridiagonal matrix A.  The factorization may also
+*  be regarded as having the form A = U'*D*U.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the L*D*L' factorization of A.
+*
+*  E       (input/output) REAL array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L' factorization of A.
+*          E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U'*D*U factorization of A.
+*
+*  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; if k < N, the factorization could not
+*               be completed, while if k = N, the factorization was
+*               completed, but D(N) <= 0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I4
+      REAL               EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MOD
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'SPTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      I4 = MOD( N-1, 4 )
+      DO 10 I = 1, I4
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 30
+         END IF
+         EI = E( I )
+         E( I ) = EI / D( I )
+         D( I+1 ) = D( I+1 ) - E( I )*EI
+   10 CONTINUE
+*
+      DO 20 I = I4 + 1, N - 4, 4
+*
+*        Drop out of the loop if d(i) <= 0: the matrix is not positive
+*        definite.
+*
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 30
+         END IF
+*
+*        Solve for e(i) and d(i+1).
+*
+         EI = E( I )
+         E( I ) = EI / D( I )
+         D( I+1 ) = D( I+1 ) - E( I )*EI
+*
+         IF( D( I+1 ).LE.ZERO ) THEN
+            INFO = I + 1
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+1) and d(i+2).
+*
+         EI = E( I+1 )
+         E( I+1 ) = EI / D( I+1 )
+         D( I+2 ) = D( I+2 ) - E( I+1 )*EI
+*
+         IF( D( I+2 ).LE.ZERO ) THEN
+            INFO = I + 2
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+2) and d(i+3).
+*
+         EI = E( I+2 )
+         E( I+2 ) = EI / D( I+2 )
+         D( I+3 ) = D( I+3 ) - E( I+2 )*EI
+*
+         IF( D( I+3 ).LE.ZERO ) THEN
+            INFO = I + 3
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+3) and d(i+4).
+*
+         EI = E( I+3 )
+         E( I+3 ) = EI / D( I+3 )
+         D( I+4 ) = D( I+4 ) - E( I+3 )*EI
+   20 CONTINUE
+*
+*     Check d(n) for positive definiteness.
+*
+      IF( D( N ).LE.ZERO )
+     $   INFO = N
+*
+   30 CONTINUE
+      RETURN
+*
+*     End of SPTTRF
+*
+      END
diff --git a/SRC/spttrs.f b/SRC/spttrs.f
new file mode 100644
index 00000000..569e2330
--- /dev/null
+++ b/SRC/spttrs.f
@@ -0,0 +1,114 @@
+      SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTTRS solves a tridiagonal system of the form
+*     A * X = B
+*  using the L*D*L' factorization of A computed by SPTTRF.  D is a
+*  diagonal matrix specified in the vector D, L is a unit bidiagonal
+*  matrix whose subdiagonal is specified in the vector E, and X and B
+*  are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          L*D*L' factorization of A.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the unit bidiagonal factor
+*          L from the L*D*L' factorization of A.  E can also be regarded
+*          as the superdiagonal of the unit bidiagonal factor U from the
+*          factorization A = U'*D*U.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPTTS2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SPTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'SPTTRS', ' ', N, NRHS, -1, -1 ) )
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL SPTTS2( N, NRHS, D, E, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL SPTTS2( N, JB, D, E, B( 1, J ), LDB )
+   10    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SPTTRS
+*
+      END
diff --git a/SRC/sptts2.f b/SRC/sptts2.f
new file mode 100644
index 00000000..cf81cc3e
--- /dev/null
+++ b/SRC/sptts2.f
@@ -0,0 +1,93 @@
+      SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               B( LDB, * ), D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SPTTS2 solves a tridiagonal system of the form
+*     A * X = B
+*  using the L*D*L' factorization of A computed by SPTTRF.  D is a
+*  diagonal matrix specified in the vector D, L is a unit bidiagonal
+*  matrix whose subdiagonal is specified in the vector E, and X and B
+*  are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          L*D*L' factorization of A.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the unit bidiagonal factor
+*          L from the L*D*L' factorization of A.  E can also be regarded
+*          as the superdiagonal of the unit bidiagonal factor U from the
+*          factorization A = U'*D*U.
+*
+*  B       (input/output) REAL array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         IF( N.EQ.1 )
+     $      CALL SSCAL( NRHS, 1. / D( 1 ), B, LDB )
+         RETURN
+      END IF
+*
+*     Solve A * X = B using the factorization A = L*D*L',
+*     overwriting each right hand side vector with its solution.
+*
+      DO 30 J = 1, NRHS
+*
+*           Solve L * x = b.
+*
+         DO 10 I = 2, N
+            B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+   10    CONTINUE
+*
+*           Solve D * L' * x = b.
+*
+         B( N, J ) = B( N, J ) / D( N )
+         DO 20 I = N - 1, 1, -1
+            B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
+   20    CONTINUE
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of SPTTS2
+*
+      END
diff --git a/SRC/srscl.f b/SRC/srscl.f
new file mode 100644
index 00000000..d40646a0
--- /dev/null
+++ b/SRC/srscl.f
@@ -0,0 +1,114 @@
+      SUBROUTINE SRSCL( 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
+      REAL               SA
+*     ..
+*     .. Array Arguments ..
+      REAL               SX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SRSCL 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) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      REAL               BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLABAD, SSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( 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 SSCAL( N, MUL, SX, INCX )
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of SRSCL
+*
+      END
diff --git a/SRC/ssbev.f b/SRC/ssbev.f
new file mode 100644
index 00000000..064b2dce
--- /dev/null
+++ b/SRC/ssbev.f
@@ -0,0 +1,205 @@
+      SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, 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, KD, LDAB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBEV computes all the eigenvalues and, optionally, eigenvectors of
+*  a real symmetric band 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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDWRK, ISCALE
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSB
+      EXTERNAL           LSAME, SLAMCH, SLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASCL, SSBTRD, SSCAL, SSTEQR, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            W( 1 ) = AB( 1, 1 )
+         ELSE
+            W( 1 ) = AB( KD+1, 1 )
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of SSBEV
+*
+      END
diff --git a/SRC/ssbevd.f b/SRC/ssbevd.f
new file mode 100644
index 00000000..64fbc827
--- /dev/null
+++ b/SRC/ssbevd.f
@@ -0,0 +1,268 @@
+      SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+     $                   LWORK, IWORK, LIWORK, 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, KD, LDAB, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBEVD computes all the eigenvalues and, optionally, eigenvectors of
+*  a real symmetric band matrix A. If eigenvectors are desired, it uses
+*  a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL 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/output) REAL array,
+*                                         dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          IF N <= 1,                LWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 2, LWORK must be at least 2*N.
+*          If JOBZ  = 'V' and N > 2, LWORK must be at least
+*                         ( 1 + 5*N + 2*N**2 ).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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 LIWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
+     $                   LLWRK2, LWMIN
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSB
+      EXTERNAL           LSAME, SLAMCH, SLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLACPY, SLASCL, SSBTRD, SSCAL, SSTEDC,
+     $                   SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LIWMIN = 1
+         LWMIN = 1
+      ELSE
+         IF( WANTZ ) THEN
+            LIWMIN = 3 + 5*N
+            LWMIN = 1 + 5*N + 2*N**2
+         ELSE
+            LIWMIN = 1
+            LWMIN = 2*N
+         END IF
+      END IF
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN 
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN 
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AB( 1, 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN 
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = INDWRK + N*N
+      LLWRK2 = LWORK - INDWK2 + 1
+      CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call SSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+         CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+     $               ZERO, WORK( INDWK2 ), N )
+         CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL SSCAL( N, ONE / SIGMA, W, 1 )
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of SSBEVD
+*
+      END
diff --git a/SRC/ssbevx.f b/SRC/ssbevx.f
new file mode 100644
index 00000000..9aad3fae
--- /dev/null
+++ b/SRC/ssbevx.f
@@ -0,0 +1,415 @@
+      SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
+     $                   VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric band matrix A.  Eigenvalues and eigenvectors can
+*  be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  Q       (output) REAL array, dimension (LDQ, N)
+*          If JOBZ = 'V', the N-by-N orthogonal matrix used in the
+*                         reduction to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'V', then
+*          LDQ >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AB to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ,
+     $                   NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSB
+      EXTERNAL           LSAME, SLAMCH, SLANSB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMV, SLACPY, SLASCL, SSBTRD, SSCAL,
+     $                   SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $     INFO = -18
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         M = 1
+         IF( LOWER ) THEN
+            TMP1 = AB( 1, 1 )
+         ELSE
+            TMP1 = AB( KD+1, 1 )
+         END IF
+         IF( VALEIG ) THEN
+            IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
+     $         M = 0
+         END IF
+         IF( M.EQ.1 ) THEN
+            W( 1 ) = TMP1
+            IF( WANTZ )
+     $         Z( 1, 1 ) = ONE
+         END IF
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF ( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      ENDIF
+      ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDWRK = INDE + N
+      CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ),
+     $             WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call SSTERF or SSTEQR.  If this fails for some
+*     eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by SSTEIN.
+*
+         DO 20 J = 1, M
+            CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSBEVX
+*
+      END
diff --git a/SRC/ssbgst.f b/SRC/ssbgst.f
new file mode 100644
index 00000000..89637a42
--- /dev/null
+++ b/SRC/ssbgst.f
@@ -0,0 +1,1345 @@
+      SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
+     $                   LDX, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO, VECT
+      INTEGER            INFO, KA, KB, LDAB, LDBB, LDX, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBGST reduces a real symmetric-definite banded generalized
+*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,
+*  such that C has the same bandwidth as A.
+*
+*  B must have been previously factorized as S**T*S by SPBSTF, using a
+*  split Cholesky factorization. A is overwritten by C = X**T*A*X, where
+*  X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
+*  bandwidth of A.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form the transformation matrix X;
+*          = 'V':  form X.
+*
+*  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 matrices A and B.  N >= 0.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the transformed matrix X**T*A*X, stored in the same
+*          format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input) REAL array, dimension (LDBB,N)
+*          The banded factor S from the split Cholesky factorization of
+*          B, as returned by SPBSTF, stored in the first KB+1 rows of
+*          the array.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  X       (output) REAL array, dimension (LDX,N)
+*          If VECT = 'V', the n-by-n matrix X.
+*          If VECT = 'N', the array X is not referenced.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.
+*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
+*
+*  WORK    (workspace) REAL array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPDATE, UPPER, WANTX
+      INTEGER            I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
+     $                   KA1, KB1, KBT, L, M, NR, NRT, NX
+      REAL               BII, RA, RA1, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGER, SLAR2V, SLARGV, SLARTG, SLARTV, SLASET,
+     $                   SROT, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTX = LSAME( VECT, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      KA1 = KA + 1
+      KB1 = KB + 1
+      INFO = 0
+      IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      INCA = LDAB*KA1
+*
+*     Initialize X to the unit matrix, if needed
+*
+      IF( WANTX )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, X, LDX )
+*
+*     Set M to the splitting point m. It must be the same value as is
+*     used in SPBSTF. The chosen value allows the arrays WORK and RWORK
+*     to be of dimension (N).
+*
+      M = ( N+KB ) / 2
+*
+*     The routine works in two phases, corresponding to the two halves
+*     of the split Cholesky factorization of B as S**T*S where
+*
+*     S = ( U    )
+*         ( M  L )
+*
+*     with U upper triangular of order m, and L lower triangular of
+*     order n-m. S has the same bandwidth as B.
+*
+*     S is treated as a product of elementary matrices:
+*
+*     S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
+*
+*     where S(i) is determined by the i-th row of S.
+*
+*     In phase 1, the index i takes the values n, n-1, ... , m+1;
+*     in phase 2, it takes the values 1, 2, ... , m.
+*
+*     For each value of i, the current matrix A is updated by forming
+*     inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
+*     the band of A. The bulge is then pushed down toward the bottom of
+*     A in phase 1, and up toward the top of A in phase 2, by applying
+*     plane rotations.
+*
+*     There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
+*     of them are linearly independent, so annihilating a bulge requires
+*     only 2*kb-1 plane rotations. The rotations are divided into a 1st
+*     set of kb-1 rotations, and a 2nd set of kb rotations.
+*
+*     Wherever possible, rotations are generated and applied in vector
+*     operations of length NR between the indices J1 and J2 (sometimes
+*     replaced by modified values NRT, J1T or J2T).
+*
+*     The cosines and sines of the rotations are stored in the array
+*     WORK. The cosines of the 1st set of rotations are stored in
+*     elements n+2:n+m-kb-1 and the sines of the 1st set in elements
+*     2:m-kb-1; the cosines of the 2nd set are stored in elements
+*     n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
+*
+*     The bulges are not formed explicitly; nonzero elements outside the
+*     band are created only when they are required for generating new
+*     rotations; they are stored in the array WORK, in positions where
+*     they are later overwritten by the sines of the rotations which
+*     annihilate them.
+*
+*     **************************** Phase 1 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = N, M + 1, -1
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M + KA + 1, N - 1
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = N + 1
+   10 CONTINUE
+      IF( UPDATE ) THEN
+         I = I - 1
+         KBT = MIN( KB, I-1 )
+         I0 = I - 1
+         I1 = MIN( N, I+KA )
+         I2 = I - KBT + KA1
+         IF( I.LT.M+1 ) THEN
+            UPDATE = .FALSE.
+            I = I + 1
+            I0 = M
+            IF( KA.EQ.0 )
+     $         GO TO 480
+            GO TO 10
+         END IF
+      ELSE
+         I = I + KA
+         IF( I.GT.N-1 )
+     $      GO TO 480
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( KB1, I )
+            DO 20 J = I, I1
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+   20       CONTINUE
+            DO 30 J = MAX( 1, I-KA ), I
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+   30       CONTINUE
+            DO 60 K = I - KBT, I - 1
+               DO 40 J = I - KBT, K
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( J-I+KB1, I )*AB( K-I+KA1, I ) -
+     $                               BB( K-I+KB1, I )*AB( J-I+KA1, I ) +
+     $                               AB( KA1, I )*BB( J-I+KB1, I )*
+     $                               BB( K-I+KB1, I )
+   40          CONTINUE
+               DO 50 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( K-I+KB1, I )*AB( J-I+KA1, I )
+   50          CONTINUE
+   60       CONTINUE
+            DO 80 J = I, I1
+               DO 70 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( K-I+KB1, I )*AB( I-J+KA1, J )
+   70          CONTINUE
+   80       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL SSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL SGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+     $                       BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+KA1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 130 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i,i-k+ka+1)
+*
+                  CALL SLARTG( AB( K+1, I-K+KA ), RA1,
+     $                         WORK( N+I-K+KA-M ), WORK( I-K+KA-M ),
+     $                         RA )
+*
+*                 create nonzero element a(i-k,i-k+ka+1) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( KB1-K, I )*RA1
+                  WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+     $                          WORK( I-K+KA-M )*AB( 1, I-K+KA )
+                  AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
+     $                              WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 90 J = J2T, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
+               AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
+   90       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL SLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
+     $                      WORK( N+J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 100 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  100          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, WORK( N+J2-M ),
+     $                      WORK( J2-M ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 110 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA,
+     $                         WORK( N+J2-M ), WORK( J2-M ), KA1 )
+  110       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 120 J = J2, J1, KA1
+                  CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J-M ), WORK( J-M ) )
+  120          CONTINUE
+            END IF
+  130    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt,i-kbt+ka+1) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
+            END IF
+         END IF
+*
+         DO 170 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 140 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J2-L+1 ), INCA,
+     $                         AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ),
+     $                         WORK( J2-KA ), KA1 )
+  140       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 150 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               WORK( N+J ) = WORK( N+J-KA )
+  150       CONTINUE
+            DO 160 J = J2, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+1 )
+               AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
+  160       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  170    CONTINUE
+*
+         DO 210 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL SLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
+     $                      WORK( N+J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 180 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  180          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, WORK( N+J2 ),
+     $                      WORK( J2 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 190 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  190       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 200 J = J2, J1, KA1
+                  CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  200          CONTINUE
+            END IF
+  210    CONTINUE
+*
+         DO 230 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 220 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA,
+     $                         WORK( N+J2-M ), WORK( J2-M ), KA1 )
+  220       CONTINUE
+  230    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 240 J = N - 1, I - KB + 2*KA + 1, -1
+               WORK( N+J-M ) = WORK( N+J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  240       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( 1, I )
+            DO 250 J = I, I1
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  250       CONTINUE
+            DO 260 J = MAX( 1, I-KA ), I
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  260       CONTINUE
+            DO 290 K = I - KBT, I - 1
+               DO 270 J = I - KBT, K
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( I-J+1, J )*AB( I-K+1, K ) -
+     $                             BB( I-K+1, K )*AB( I-J+1, J ) +
+     $                             AB( 1, I )*BB( I-J+1, J )*
+     $                             BB( I-K+1, K )
+  270          CONTINUE
+               DO 280 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( I-K+1, K )*AB( I-J+1, J )
+  280          CONTINUE
+  290       CONTINUE
+            DO 310 J = I, I1
+               DO 300 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( I-K+1, K )*AB( J-I+1, I )
+  300          CONTINUE
+  310       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL SSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL SGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+     $                       BB( KBT+1, I-KBT ), LDBB-1,
+     $                       X( M+1, I-KBT ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 360 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i-k+ka+1,i)
+*
+                  CALL SLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ),
+     $                         WORK( I-K+KA-M ), RA )
+*
+*                 create nonzero element a(i-k+ka+1,i-k) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( K+1, I-K )*RA1
+                  WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+     $                          WORK( I-K+KA-M )*AB( KA1, I-K )
+                  AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
+     $                             WORK( N+I-K+KA-M )*AB( KA1, I-K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 320 J = J2T, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
+  320       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL SLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
+     $                      KA1, WORK( N+J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 330 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  330          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 340 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  340       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 350 J = J2, J1, KA1
+                  CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J-M ), WORK( J-M ) )
+  350          CONTINUE
+            END IF
+  360    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt+ka+1,i-kbt) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
+            END IF
+         END IF
+*
+         DO 400 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 370 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
+     $                         AB( KA1-L, J2-KA+1 ), INCA,
+     $                         WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
+  370       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 380 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               WORK( N+J ) = WORK( N+J-KA )
+  380       CONTINUE
+            DO 390 J = J2, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
+  390       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  400    CONTINUE
+*
+         DO 440 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL SLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
+     $                      WORK( N+J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 410 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  410          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 420 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ),
+     $                         WORK( J2 ), KA1 )
+  420       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 430 J = J2, J1, KA1
+                  CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  430          CONTINUE
+            END IF
+  440    CONTINUE
+*
+         DO 460 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 450 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  450       CONTINUE
+  460    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 470 J = N - 1, I - KB + 2*KA + 1, -1
+               WORK( N+J-M ) = WORK( N+J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  470       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 10
+*
+  480 CONTINUE
+*
+*     **************************** Phase 2 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = 1, M
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M - KA - 1, 2, -1
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = 0
+  490 CONTINUE
+      IF( UPDATE ) THEN
+         I = I + 1
+         KBT = MIN( KB, M-I )
+         I0 = I + 1
+         I1 = MAX( 1, I-KA )
+         I2 = I + KBT - KA1
+         IF( I.GT.M ) THEN
+            UPDATE = .FALSE.
+            I = I - 1
+            I0 = M + 1
+            IF( KA.EQ.0 )
+     $         RETURN
+            GO TO 490
+         END IF
+      ELSE
+         I = I - KA
+         IF( I.LT.2 )
+     $      RETURN
+      END IF
+*
+      IF( I.LT.M-KBT ) THEN
+         NX = M
+      ELSE
+         NX = N
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( KB1, I )
+            DO 500 J = I1, I
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+  500       CONTINUE
+            DO 510 J = I, MIN( N, I+KA )
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+  510       CONTINUE
+            DO 540 K = I + 1, I + KBT
+               DO 520 J = K, I + KBT
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( I-J+KB1, J )*AB( I-K+KA1, K ) -
+     $                               BB( I-K+KB1, K )*AB( I-J+KA1, J ) +
+     $                               AB( KA1, I )*BB( I-J+KB1, J )*
+     $                               BB( I-K+KB1, K )
+  520          CONTINUE
+               DO 530 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( I-K+KB1, K )*AB( I-J+KA1, J )
+  530          CONTINUE
+  540       CONTINUE
+            DO 560 J = I1, I
+               DO 550 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( I-K+KB1, K )*AB( J-I+KA1, I )
+  550          CONTINUE
+  560       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL SSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL SGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ),
+     $                       LDBB-1, X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+KA1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 610 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i+k-ka-1,i)
+*
+                  CALL SLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ),
+     $                         WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k-ka-1,i+k) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( KB1-K, I+K )*RA1
+                  WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+     $                               WORK( I+K-KA )*AB( 1, I+K )
+                  AB( 1, I+K ) = WORK( I+K-KA )*T +
+     $                           WORK( N+I+K-KA )*AB( 1, I+K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 570 J = J1, J2T, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
+  570       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL SLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
+     $                      WORK( N+J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 580 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA, WORK( N+J1 ),
+     $                         WORK( J1 ), KA1 )
+  580          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, WORK( N+J1 ),
+     $                      WORK( J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 590 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+     $                         WORK( J1T ), KA1 )
+  590       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 600 J = J1, J2, KA1
+                  CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  600          CONTINUE
+            END IF
+  610    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt-ka-1,i+kbt) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
+            END IF
+         END IF
+*
+         DO 650 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 620 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J1T+KA ), INCA,
+     $                         AB( L+1, J1T+KA-1 ), INCA,
+     $                         WORK( N+M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  620       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 630 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+  630       CONTINUE
+            DO 640 J = J1, J2, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
+  640       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  650    CONTINUE
+*
+         DO 690 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL SLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 660 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA,
+     $                         WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
+  660          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 670 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA,
+     $                         WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  670       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 680 J = J1, J2, KA1
+                  CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+M-KB+J ), WORK( M-KB+J ) )
+  680          CONTINUE
+            END IF
+  690    CONTINUE
+*
+         DO 710 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 700 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+     $                         WORK( J1T ), KA1 )
+  700       CONTINUE
+  710    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
+               WORK( N+J ) = WORK( N+J+KA )
+               WORK( J ) = WORK( J+KA )
+  720       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**T * A * inv(S(i))
+*
+            BII = BB( 1, I )
+            DO 730 J = I1, I
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  730       CONTINUE
+            DO 740 J = I, MIN( N, I+KA )
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  740       CONTINUE
+            DO 770 K = I + 1, I + KBT
+               DO 750 J = K, I + KBT
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( J-I+1, I )*AB( K-I+1, I ) -
+     $                             BB( K-I+1, I )*AB( J-I+1, I ) +
+     $                             AB( 1, I )*BB( J-I+1, I )*
+     $                             BB( K-I+1, I )
+  750          CONTINUE
+               DO 760 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( K-I+1, I )*AB( J-I+1, I )
+  760          CONTINUE
+  770       CONTINUE
+            DO 790 J = I1, I
+               DO 780 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( K-I+1, I )*AB( I-J+1, J )
+  780          CONTINUE
+  790       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL SSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL SGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1,
+     $                       X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 840 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i,i+k-ka-1)
+*
+                  CALL SLARTG( AB( KA1-K, I+K-KA ), RA1,
+     $                         WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k,i+k-ka-1) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( K+1, I )*RA1
+                  WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+     $                               WORK( I+K-KA )*AB( KA1, I+K-KA )
+                  AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
+     $                                WORK( N+I+K-KA )*AB( KA1, I+K-KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 800 J = J1, J2T, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
+  800       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL SLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
+     $                      WORK( N+J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 810 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
+  810          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, WORK( N+J1 ),
+     $                      WORK( J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 820 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         WORK( N+J1T ), WORK( J1T ), KA1 )
+  820       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 830 J = J1, J2, KA1
+                  CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+J ), WORK( J ) )
+  830          CONTINUE
+            END IF
+  840    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt,i+kbt-ka-1) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
+            END IF
+         END IF
+*
+         DO 880 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 850 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
+     $                         AB( KA1-L, J1T+L-1 ), INCA,
+     $                         WORK( N+M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  850       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 860 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+  860       CONTINUE
+            DO 870 J = J1, J2, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
+  870       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  880    CONTINUE
+*
+         DO 920 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL SLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 890 L = 1, KA - 1
+                  CALL SLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ),
+     $                         KA1 )
+  890          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL SLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 900 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  900       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 910 J = J1, J2, KA1
+                  CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       WORK( N+M-KB+J ), WORK( M-KB+J ) )
+  910          CONTINUE
+            END IF
+  920    CONTINUE
+*
+         DO 940 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 930 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         WORK( N+J1T ), WORK( J1T ), KA1 )
+  930       CONTINUE
+  940    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
+               WORK( N+J ) = WORK( N+J+KA )
+               WORK( J ) = WORK( J+KA )
+  950       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 490
+*
+*     End of SSBGST
+*
+      END
diff --git a/SRC/ssbgv.f b/SRC/ssbgv.f
new file mode 100644
index 00000000..d89bb921
--- /dev/null
+++ b/SRC/ssbgv.f
@@ -0,0 +1,188 @@
+      SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, 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, KA, KB, LDAB, LDBB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), BB( LDBB, * ), W( * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
+*  and banded, and B is also positive definite.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) REAL array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**T*S, as returned by SPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**T*B*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= N.
+*
+*  WORK    (workspace) REAL 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, and i is:
+*             <= N:  the algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then SPBSTF
+*                    returned INFO = i: 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          VECT
+      INTEGER            IINFO, INDE, INDWRK
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     Reduce to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                INFO )
+      END IF
+      RETURN
+*
+*     End of SSBGV
+*
+      END
diff --git a/SRC/ssbgvd.f b/SRC/ssbgvd.f
new file mode 100644
index 00000000..95f46e10
--- /dev/null
+++ b/SRC/ssbgvd.f
@@ -0,0 +1,271 @@
+      SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
+     $                   Z, LDZ, WORK, LWORK, IWORK, LIWORK, 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, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), BB( LDBB, * ), W( * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite banded eigenproblem, of the
+*  form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric and
+*  banded, and B is also positive definite.  If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) REAL array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**T*S, as returned by SPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i).  The eigenvectors are
+*          normalized so Z**T*B*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) REAL 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 N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= 3*N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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 algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then SPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          VECT
+      INTEGER            IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2,
+     $                   LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLACPY, SPBSTF, SSBGST, SSBTRD, SSTEDC,
+     $                   SSTERF, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LIWMIN = 1
+         LWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LIWMIN = 3 + 5*N
+         LWMIN = 1 + 5*N + 2*N**2
+      ELSE
+         LIWMIN = 1
+         LWMIN = 2*N
+      END IF
+*
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -14
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = INDWRK + N*N
+      LLWRK2 = LWORK - INDWK2 + 1
+      CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     Reduce to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+     $             WORK( INDWRK ), IINFO )
+*
+*     For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+         CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+     $               ZERO, WORK( INDWK2 ), N )
+         CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of SSBGVD
+*
+      END
diff --git a/SRC/ssbgvx.f b/SRC/ssbgvx.f
new file mode 100644
index 00000000..e2baaac2
--- /dev/null
+++ b/SRC/ssbgvx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB,
+     $                   LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z,
+     $                   LDZ, WORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
+     $                   N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
+     $                   W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a real generalized symmetric-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric
+*  and banded, and B is also positive definite.  Eigenvalues and
+*  eigenvectors can be selected by specifying either all eigenvalues,
+*  a range of values or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) REAL array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**T*S, as returned by SPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  Q       (output) REAL array, dimension (LDQ, N)
+*          If JOBZ = 'V', the n-by-n matrix used in the reduction of
+*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
+*          and consequently C to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'N',
+*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i).  The eigenvectors are
+*          normalized so Z**T*B*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) REAL array, dimension (7N)
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (5N)
+*
+*  IFAIL   (output) INTEGER array, dimension (M)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvalues that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0 : successful exit
+*          < 0 : if INFO = -i, the i-th argument had an illegal value
+*          <= N: if INFO = i, then i eigenvectors failed to converge.
+*                  Their indices are stored in IFAIL.
+*          > N : SPBSTF returned an error code; i.e.,
+*                if INFO = N + i, for 1 <= i <= N, then the leading
+*                minor of order i of B is not positive definite.
+*                The factorization of B could not be completed and
+*                no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
+      CHARACTER          ORDER, VECT
+      INTEGER            I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
+     $                   INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
+      REAL               TMP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SGEMV, SLACPY, SPBSTF, SSBGST, SSBTRD,
+     $                   SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -8
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -10
+      ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
+         INFO = -12
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -14
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -15
+            ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -16
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -21
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
+     $             WORK, IINFO )
+*
+*     Reduce symmetric band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDWRK = INDE + N
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ),
+     $             WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call SSTERF or SSTEQR.  If this fails for some
+*     eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+         IF( .NOT.WANTZ ) THEN
+            CALL SSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired,
+*     call SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply transformation matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by SSTEIN.
+*
+         DO 20 J = 1, M
+            CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+   30 CONTINUE
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSBGVX
+*
+      END
diff --git a/SRC/ssbtrd.f b/SRC/ssbtrd.f
new file mode 100644
index 00000000..72fb9e17
--- /dev/null
+++ b/SRC/ssbtrd.f
@@ -0,0 +1,552 @@
+      SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, 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, VECT
+      INTEGER            INFO, KD, LDAB, LDQ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSBTRD reduces a real symmetric band matrix A to symmetric
+*  tridiagonal form T by an orthogonal similarity transformation:
+*  Q**T * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form Q;
+*          = 'V':  form Q;
+*          = 'U':  update a matrix X, by forming X*Q.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) REAL array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          On exit, the diagonal elements of AB are overwritten by the
+*          diagonal elements of the tridiagonal matrix T; if KD > 0, the
+*          elements on the first superdiagonal (if UPLO = 'U') or the
+*          first subdiagonal (if UPLO = 'L') are overwritten by the
+*          off-diagonal elements of T; the rest of AB is overwritten by
+*          values generated during the reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  D       (output) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T.
+*
+*  E       (output) REAL array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
+*
+*  Q       (input/output) REAL array, dimension (LDQ,N)
+*          On entry, if VECT = 'U', then Q must contain an N-by-N
+*          matrix X; if VECT = 'N' or 'V', then Q need not be set.
+*
+*          On exit:
+*          if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
+*          if VECT = 'U', Q contains the product X*Q;
+*          if VECT = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
+*
+*  WORK    (workspace) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Modified by Linda Kaufman, Bell Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            INITQ, UPPER, WANTQ
+      INTEGER            I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
+     $                   J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
+     $                   KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
+      REAL               TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAR2V, SLARGV, SLARTG, SLARTV, SLASET, SROT,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INITQ = LSAME( VECT, 'V' )
+      WANTQ = INITQ .OR. LSAME( VECT, 'U' )
+      UPPER = LSAME( UPLO, 'U' )
+      KD1 = KD + 1
+      KDM1 = KD - 1
+      INCX = LDAB - 1
+      IQEND = 1
+*
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD1 ) THEN
+         INFO = -6
+      ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSBTRD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize Q to the unit matrix, if needed
+*
+      IF( INITQ )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+*     Wherever possible, plane rotations are generated and applied in
+*     vector operations of length NR over the index set J1:J2:KD1.
+*
+*     The cosines and sines of the plane rotations are stored in the
+*     arrays D and WORK.
+*
+      INCA = KD1*LDAB
+      KDN = MIN( N-1, KD )
+      IF( UPPER ) THEN
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to tridiagonal form, working with upper triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            DO 90 I = 1, N - 2
+*
+*              Reduce i-th row of matrix to tridiagonal form
+*
+               DO 80 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL SLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
+     $                            KD1, D( J1 ), KD1 )
+*
+*                    apply rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    SLARTV or SROT is used
+*
+                     IF( NR.GE.2*KD-1 ) THEN
+                        DO 10 L = 1, KD - 1
+                           CALL SLARTV( NR, AB( L+1, J1-1 ), INCA,
+     $                                  AB( L, J1 ), INCA, D( J1 ),
+     $                                  WORK( J1 ), KD1 )
+   10                   CONTINUE
+*
+                     ELSE
+                        JEND = J1 + ( NR-1 )*KD1
+                        DO 20 JINC = J1, JEND, KD1
+                           CALL SROT( KDM1, AB( 2, JINC-1 ), 1,
+     $                                AB( 1, JINC ), 1, D( JINC ),
+     $                                WORK( JINC ) )
+   20                   CONTINUE
+                     END IF
+                  END IF
+*
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i,i+k-1)
+*                       within the band
+*
+                        CALL SLARTG( AB( KD-K+3, I+K-2 ),
+     $                               AB( KD-K+2, I+K-1 ), D( I+K-1 ),
+     $                               WORK( I+K-1 ), TEMP )
+                        AB( KD-K+3, I+K-2 ) = TEMP
+*
+*                       apply rotation from the right
+*
+                        CALL SROT( K-3, AB( KD-K+4, I+K-2 ), 1,
+     $                             AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL SLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
+     $                            AB( KD, J1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the left
+*
+                  IF( NR.GT.0 ) THEN
+                     IF( 2*KD-1.LT.NR ) THEN
+*
+*                    Dependent on the the number of diagonals either
+*                    SLARTV or SROT is used
+*
+                        DO 30 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL SLARTV( NRT, AB( KD-L, J1+L ), INCA,
+     $                                     AB( KD-L+1, J1+L ), INCA,
+     $                                     D( J1 ), WORK( J1 ), KD1 )
+   30                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 40 JIN = J1, J1END, KD1
+                              CALL SROT( KD-1, AB( KD-1, JIN+1 ), INCX,
+     $                                   AB( KD, JIN+1 ), INCX,
+     $                                   D( JIN ), WORK( JIN ) )
+   40                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL SROT( LEND, AB( KD-1, LAST+1 ), INCX,
+     $                                AB( KD, LAST+1 ), INCX, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 50 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL SROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), WORK( J ) )
+   50                   CONTINUE
+                     ELSE
+*
+                        DO 60 J = J1, J2, KD1
+                           CALL SROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), WORK( J ) )
+   60                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 70 J = J1, J2, KD1
+*
+*                    create nonzero element a(j-1,j+kd) outside the band
+*                    and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
+                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
+   70             CONTINUE
+   80          CONTINUE
+   90       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           copy off-diagonal elements to E
+*
+            DO 100 I = 1, N - 1
+               E( I ) = AB( KD, I+1 )
+  100       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 110 I = 1, N - 1
+               E( I ) = ZERO
+  110       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 120 I = 1, N
+            D( I ) = AB( KD1, I )
+  120    CONTINUE
+*
+      ELSE
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to tridiagonal form, working with lower triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            DO 210 I = 1, N - 2
+*
+*              Reduce i-th column of matrix to tridiagonal form
+*
+               DO 200 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL SLARGV( NR, AB( KD1, J1-KD1 ), INCA,
+     $                            WORK( J1 ), KD1, D( J1 ), KD1 )
+*
+*                    apply plane rotations from one side
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    SLARTV or SROT is used
+*
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 130 L = 1, KD - 1
+                           CALL SLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
+     $                                  AB( KD1-L+1, J1-KD1+L ), INCA,
+     $                                  D( J1 ), WORK( J1 ), KD1 )
+  130                   CONTINUE
+                     ELSE
+                        JEND = J1 + KD1*( NR-1 )
+                        DO 140 JINC = J1, JEND, KD1
+                           CALL SROT( KDM1, AB( KD, JINC-KD ), INCX,
+     $                                AB( KD1, JINC-KD ), INCX,
+     $                                D( JINC ), WORK( JINC ) )
+  140                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i+k-1,i)
+*                       within the band
+*
+                        CALL SLARTG( AB( K-1, I ), AB( K, I ),
+     $                               D( I+K-1 ), WORK( I+K-1 ), TEMP )
+                        AB( K-1, I ) = TEMP
+*
+*                       apply rotation from the left
+*
+                        CALL SROT( K-3, AB( K-2, I+1 ), LDAB-1,
+     $                             AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL SLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
+     $                            AB( 2, J1-1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    SLARTV or SROT is used
+*
+                  IF( NR.GT.0 ) THEN
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 150 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL SLARTV( NRT, AB( L+2, J1-1 ), INCA,
+     $                                     AB( L+1, J1 ), INCA, D( J1 ),
+     $                                     WORK( J1 ), KD1 )
+  150                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 160 J1INC = J1, J1END, KD1
+                              CALL SROT( KDM1, AB( 3, J1INC-1 ), 1,
+     $                                   AB( 2, J1INC ), 1, D( J1INC ),
+     $                                   WORK( J1INC ) )
+  160                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL SROT( LEND, AB( 3, LAST-1 ), 1,
+     $                                AB( 2, LAST ), 1, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+*
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 170 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL SROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), WORK( J ) )
+  170                   CONTINUE
+                     ELSE
+*
+                        DO 180 J = J1, J2, KD1
+                           CALL SROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), WORK( J ) )
+  180                   CONTINUE
+                     END IF
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 190 J = J1, J2, KD1
+*
+*                    create nonzero element a(j+kd,j-1) outside the
+*                    band and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( KD1, J )
+                     AB( KD1, J ) = D( J )*AB( KD1, J )
+  190             CONTINUE
+  200          CONTINUE
+  210       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           copy off-diagonal elements to E
+*
+            DO 220 I = 1, N - 1
+               E( I ) = AB( 2, I )
+  220       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 230 I = 1, N - 1
+               E( I ) = ZERO
+  230       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 240 I = 1, N
+            D( I ) = AB( 1, I )
+  240    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSBTRD
+*
+      END
diff --git a/SRC/sspcon.f b/SRC/sspcon.f
new file mode 100644
index 00000000..12c77121
--- /dev/null
+++ b/SRC/sspcon.f
@@ -0,0 +1,162 @@
+      SUBROUTINE SSPCON( UPLO, N, AP, 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 SLACN2 in place of SLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric packed matrix A using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by SSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by SSPTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IP, KASE
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SSPTRS, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         IP = N*( N+1 ) / 2
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP - I
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         IP = 1
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP + N - I + 1
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL SLACN2( 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 SSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of SSPCON
+*
+      END
diff --git a/SRC/sspev.f b/SRC/sspev.f
new file mode 100644
index 00000000..21ea1dea
--- /dev/null
+++ b/SRC/sspev.f
@@ -0,0 +1,187 @@
+      SUBROUTINE SSPEV( 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 ..
+      REAL               AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPEV 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) REAL 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSP
+      EXTERNAL           LSAME, SLAMCH, SLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SOPGTR, SSCAL, SSPTRD, SSTEQR, SSTERF, 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( 'SSPEV ', -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 = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = SLANSP( '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 SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      CALL SSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     SOPGTR to generate the orthogonal matrix, then call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         INDWRK = INDTAU + N
+         CALL SOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+         CALL SSTEQR( 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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of SSPEV
+*
+      END
diff --git a/SRC/sspevd.f b/SRC/sspevd.f
new file mode 100644
index 00000000..b84319df
--- /dev/null
+++ b/SRC/sspevd.f
@@ -0,0 +1,251 @@
+      SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
+     $                   IWORK, LIWORK, 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, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPEVD computes all the eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A in packed storage. If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) REAL 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL 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/output) REAL array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least
+*                                                 1 + 6*N + N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTZ
+      INTEGER            IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,
+     $                   LLWORK, LWMIN
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSP
+      EXTERNAL           LSAME, SLAMCH, SLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SOPMTR, SSCAL, SSPTRD, SSTEDC, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LIWMIN = 3 + 5*N
+               LWMIN = 1 + 6*N + N**2
+            ELSE
+               LIWMIN = 1
+               LWMIN = 2*N
+            END IF
+         END IF
+         IWORK( 1 ) = LIWMIN
+         WORK( 1 ) = LWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -9
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN 
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN 
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN 
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = SLANSP( '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 SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      CALL SSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+*     tridiagonal matrix, then call SOPMTR to multiply it by the
+*     Householder transformations represented in AP.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         INDWRK = INDTAU + N
+         LLWORK = LWORK - INDWRK + 1
+         CALL SSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                LLWORK, IWORK, LIWORK, INFO )
+         CALL SOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL SSCAL( N, ONE / SIGMA, W, 1 )
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of SSPEVD
+*
+      END
diff --git a/SRC/sspevx.f b/SRC/sspevx.f
new file mode 100644
index 00000000..8419d7e5
--- /dev/null
+++ b/SRC/sspevx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL,
+     $                   INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A in packed storage.  Eigenvalues/vectors
+*  can be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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) REAL 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.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the selected eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (8*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1,
+     $                   J, JJ, NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSP
+      EXTERNAL           LSAME, SLAMCH, SLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SOPGTR, SOPMTR, SSCAL, SSPTRD, SSTEBZ,
+     $                   SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -14
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = AP( 1 )
+         ELSE
+            IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
+               M = 1
+               W( 1 ) = AP( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF ( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      ENDIF
+      ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+      INDTAU = 1
+      INDE = INDTAU + N
+      INDD = INDE + N
+      INDWRK = INDD + N
+      CALL SSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
+     $             WORK( INDTAU ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call SSTERF or SOPGTR and SSTEQR.  If this fails
+*     for some eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL SOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                   WORK( INDWRK ), IINFO )
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 20
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by SSTEIN.
+*
+         CALL SOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   20 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 40 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 30 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   30       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSPEVX
+*
+      END
diff --git a/SRC/sspgst.f b/SRC/sspgst.f
new file mode 100644
index 00000000..e78ce11e
--- /dev/null
+++ b/SRC/sspgst.f
@@ -0,0 +1,208 @@
+      SUBROUTINE SSPGST( 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 ..
+      REAL               AP( * ), BP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPGST 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 SPPTRF.
+*
+*  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) REAL 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) REAL 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 SPPTRF.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, HALF
+      PARAMETER          ( ONE = 1.0, HALF = 0.5 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
+      REAL               AJJ, AKK, BJJ, BKK, CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SSCAL, SSPMV, SSPR2, STPMV, STPSV,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. 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( 'SSPGST', -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 STPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
+     $                     AP( J1 ), 1 )
+               CALL SSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
+     $                     AP( J1 ), 1 )
+               CALL SSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
+               AP( JJ ) = ( AP( JJ )-SDOT( 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 SSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
+                  CT = -HALF*AKK
+                  CALL SAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL SSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
+     $                        BP( KK+1 ), 1, AP( K1K1 ) )
+                  CALL SAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL STPSV( 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 STPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
+     $                     AP( K1 ), 1 )
+               CT = HALF*AKK
+               CALL SAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL SSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
+     $                     AP )
+               CALL SAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL SSCAL( 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 + SDOT( N-J, AP( JJ+1 ), 1,
+     $                    BP( JJ+1 ), 1 )
+               CALL SSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
+               CALL SSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
+     $                     ONE, AP( JJ+1 ), 1 )
+               CALL STPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
+     $                     BP( JJ ), AP( JJ ), 1 )
+               JJ = J1J1
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of SSPGST
+*
+      END
diff --git a/SRC/sspgv.f b/SRC/sspgv.f
new file mode 100644
index 00000000..40840562
--- /dev/null
+++ b/SRC/sspgv.f
@@ -0,0 +1,195 @@
+      SUBROUTINE SSPGV( 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 ..
+      REAL               AP( * ), BP( * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPGV 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) REAL 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) REAL 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL 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) REAL array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  SPPTRF or SSPEV returned an error code:
+*             <= N:  if INFO = i, SSPEV 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           SPPTRF, SSPEV, SSPGST, STPMV, STPSV, 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( 'SSPGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL SPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL SSPEV( 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 STPSV( 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 STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of SSPGV
+*
+      END
diff --git a/SRC/sspgvd.f b/SRC/sspgvd.f
new file mode 100644
index 00000000..7458de40
--- /dev/null
+++ b/SRC/sspgvd.f
@@ -0,0 +1,277 @@
+      SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                   LWORK, IWORK, LIWORK, 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, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AP( * ), BP( * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
+*  B are assumed to be symmetric, stored in packed format, and B is also
+*  positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) REAL 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) REAL 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) REAL 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/output) REAL array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= 2*N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  SPPTRF or SSPEVD returned an error code:
+*             <= N:  if INFO = i, SSPEVD 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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J, LIWMIN, LWMIN, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPPTRF, SSPEVD, SSPGST, STPMV, STPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LIWMIN = 3 + 5*N
+               LWMIN = 1 + 6*N + 2*N**2
+            ELSE
+               LIWMIN = 1
+               LWMIN = 2*N
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of BP.
+*
+      CALL SPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK,
+     $             LIWORK, INFO )
+      LWMIN = MAX( REAL( LWMIN ), REAL( WORK( 1 ) ) )
+      LIWMIN = MAX( REAL( LIWMIN ), REAL( IWORK( 1 ) ) )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            DO 10 J = 1, NEIG
+               CALL STPSV( 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 STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of SSPGVD
+*
+      END
diff --git a/SRC/sspgvx.f b/SRC/sspgvx.f
new file mode 100644
index 00000000..e92d3bd9
--- /dev/null
+++ b/SRC/sspgvx.f
@@ -0,0 +1,292 @@
+      SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
+     $                   IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               AP( * ), BP( * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A
+*  and B are assumed to be symmetric, stored in packed storage, and B
+*  is also positive definite.  Eigenvalues and eigenvectors can be
+*  selected by specifying either a range of values or a range of indices
+*  for the desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A and B are stored;
+*          = 'L':  Lower triangle of A and B are stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix pencil (A,B).  N >= 0.
+*
+*  AP      (input/output) REAL 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) REAL 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.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (8*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  SPPTRF or SSPEVX returned an error code:
+*             <= N:  if INFO = i, SSPEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      UPPER = LSAME( UPLO, 'U' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL ) THEN
+               INFO = -9
+            END IF
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 ) THEN
+               INFO = -10
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -11
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL SPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
+     $             W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            DO 10 J = 1, M
+               CALL STPSV( 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, M
+               CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of SSPGVX
+*
+      END
diff --git a/SRC/ssprfs.f b/SRC/ssprfs.f
new file mode 100644
index 00000000..79528f47
--- /dev/null
+++ b/SRC/ssprfs.f
@@ -0,0 +1,335 @@
+      SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, 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 SLACN2 in place of SLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  AFP     (input) REAL array, dimension (N*(N+1)/2)
+*          The factored form of the matrix A.  AFP contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by SSPTRF, stored as a packed
+*          triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by SSPTRF.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SSPTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, SSPMV, SSPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+     $               1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
+            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of SSPRFS
+*
+      END
diff --git a/SRC/sspsv.f b/SRC/sspsv.f
new file mode 100644
index 00000000..a8737e19
--- /dev/null
+++ b/SRC/sspsv.f
@@ -0,0 +1,148 @@
+      SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric matrix stored in packed format and X
+*  and B are N-by-NRHS matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**T,  if UPLO = 'U', or
+*     A = L * D * L**T,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, D is symmetric and block diagonal with 1-by-1
+*  and 2-by-2 diagonal blocks.  The factored form of A is then used to
+*  solve the system of equations A * X = B.
+*
+*  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.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by SSPTRF.  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) REAL 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).
+*
+*  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.
+*
+*  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 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSPTRF, SSPTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL SSPTRF( UPLO, N, AP, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of SSPSV
+*
+      END
diff --git a/SRC/sspsvx.f b/SRC/sspsvx.f
new file mode 100644
index 00000000..69b2b025
--- /dev/null
+++ b/SRC/sspsvx.f
@@ -0,0 +1,277 @@
+      SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, 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          FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
+*  A = L*D*L**T to compute the solution to a real system of linear
+*  equations A * X = B, where A is an N-by-N symmetric matrix stored
+*  in packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AFP and IPIV contain the factored form of
+*                  A.  AP, AFP and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*  AFP     (input or output) REAL array, dimension
+*                            (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains details of the interchanges and the block structure
+*          of D, as determined by SSPTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by SSPTRF.
+*
+*  B       (input) REAL array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANSP
+      EXTERNAL           LSAME, SLAMCH, SLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SSPCON, SSPRFS, SSPTRF, SSPTRS,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL SSPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, IWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of SSPSVX
+*
+      END
diff --git a/SRC/ssptrd.f b/SRC/ssptrd.f
new file mode 100644
index 00000000..68d3d459
--- /dev/null
+++ b/SRC/ssptrd.f
@@ -0,0 +1,227 @@
+      SUBROUTINE SSPTRD( 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 ..
+      REAL               AP( * ), D( * ), E( * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPTRD 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) REAL 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) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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) REAL 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 ..
+      REAL               ONE, ZERO, HALF
+      PARAMETER          ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, I1, I1I1, II
+      REAL               ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SLARFG, SSPMV, SSPR2, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. 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( 'SSPTRD', -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 SLARFG( 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 SSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
+     $                     1 )
+*
+*              Compute  w := y - 1/2 * tau * (y'*v) * v
+*
+               ALPHA = -HALF*TAUI*SDOT( I, TAU, 1, AP( I1 ), 1 )
+               CALL SAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL SSPR2( 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 SLARFG( 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 SSPMV( 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*SDOT( N-I, TAU( I ), 1, AP( II+1 ),
+     $                 1 )
+               CALL SAXPY( 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 SSPR2( 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 SSPTRD
+*
+      END
diff --git a/SRC/ssptrf.f b/SRC/ssptrf.f
new file mode 100644
index 00000000..28c53c07
--- /dev/null
+++ b/SRC/ssptrf.f
@@ -0,0 +1,547 @@
+      SUBROUTINE SSPTRF( 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( * )
+      REAL               AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPTRF 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
+     $                   KSTEP, KX, NPP
+      REAL               ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+     $                   ROWMAX, T, WK, WKM1, WKP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      EXTERNAL           LSAME, ISAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSPR, SSWAP, 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( 'SSPTRF', -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 = ISAMAX( 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 = ISAMAX( 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 SSWAP( 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 SSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+*              Store U(k) in column k
+*
+               CALL SSCAL( 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 + ISAMAX( 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 + ISAMAX( 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 SSWAP( 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 SSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+     $                       AP( KC+N-K+1 ) )
+*
+*                 Store L(k) in column K
+*
+                  CALL SSCAL( 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 SSPTRF
+*
+      END
diff --git a/SRC/ssptri.f b/SRC/ssptri.f
new file mode 100644
index 00000000..40aa1c80
--- /dev/null
+++ b/SRC/ssptri.f
@@ -0,0 +1,334 @@
+      SUBROUTINE SSPTRI( UPLO, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPTRI computes the inverse of a real symmetric indefinite matrix
+*  A in packed storage using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by SSPTRF.
+*
+*  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.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by SSPTRF,
+*          stored as a packed triangular matrix.
+*
+*          On exit, if INFO = 0, the (symmetric) inverse of the original
+*          matrix, stored as a packed triangular matrix. The j-th column
+*          of inv(A) is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+*          if UPLO = 'L',
+*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by SSPTRF.
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+      REAL               AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SSPMV, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         KP = N*( N+1 ) / 2
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP - INFO
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         KP = 1
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP + N - INFO + 1
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         KCNEXT = KC + K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC+K-1 ) = ONE / AP( KC+K-1 )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL SCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        SDOT( K-1, WORK, 1, AP( KC ), 1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+K-1 ) )
+            AK = AP( KC+K-1 ) / T
+            AKP1 = AP( KCNEXT+K ) / T
+            AKKP1 = AP( KCNEXT+K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KC+K-1 ) = AKP1 / D
+            AP( KCNEXT+K ) = AK / D
+            AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL SCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        SDOT( K-1, WORK, 1, AP( KC ), 1 )
+               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+     $                            SDOT( K-1, AP( KC ), 1, AP( KCNEXT ),
+     $                            1 )
+               CALL SCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+               CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
+     $                     AP( KCNEXT ), 1 )
+               AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+     $                          SDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT + K + 1
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            KPC = ( KP-1 )*KP / 2 + 1
+            CALL SSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+            KX = KPC + KP - 1
+            DO 40 J = KP + 1, K - 1
+               KX = KX + J - 1
+               TEMP = AP( KC+J-1 )
+               AP( KC+J-1 ) = AP( KX )
+               AP( KX ) = TEMP
+   40       CONTINUE
+            TEMP = AP( KC+K-1 )
+            AP( KC+K-1 ) = AP( KPC+KP-1 )
+            AP( KPC+KP-1 ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC+K+K-1 )
+               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+               AP( KC+K+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         KC = KCNEXT
+         GO TO 30
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         NPP = N*( N+1 ) / 2
+         K = N
+         KC = NPP
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         KCNEXT = KC - ( N-K+2 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC ) = ONE / AP( KC )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL SCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL SSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - SDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+1 ) )
+            AK = AP( KCNEXT ) / T
+            AKP1 = AP( KC ) / T
+            AKKP1 = AP( KCNEXT+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KCNEXT ) = AKP1 / D
+            AP( KC ) = AK / D
+            AP( KCNEXT+1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL SCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL SSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - SDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+     $                          SDOT( N-K, AP( KC+1 ), 1,
+     $                          AP( KCNEXT+2 ), 1 )
+               CALL SCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+               CALL SSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KCNEXT+2 ), 1 )
+               AP( KCNEXT ) = AP( KCNEXT ) -
+     $                        SDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT - ( N-K+3 )
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+            IF( KP.LT.N )
+     $         CALL SSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+            KX = KC + KP - K
+            DO 70 J = K + 1, KP - 1
+               KX = KX + N - J + 1
+               TEMP = AP( KC+J-K )
+               AP( KC+J-K ) = AP( KX )
+               AP( KX ) = TEMP
+   70       CONTINUE
+            TEMP = AP( KC )
+            AP( KC ) = AP( KPC )
+            AP( KPC ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC-N+K-1 )
+               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+               AP( KC-N+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         KC = KCNEXT
+         GO TO 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSPTRI
+*
+      END
diff --git a/SRC/ssptrs.f b/SRC/ssptrs.f
new file mode 100644
index 00000000..566163b2
--- /dev/null
+++ b/SRC/ssptrs.f
@@ -0,0 +1,377 @@
+      SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      REAL               AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSPTRS solves a system of linear equations A*X = B with a real
+*  symmetric matrix A stored in packed format using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by SSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by SSPTRF.
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KP
+      REAL               AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SGER, SSCAL, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSPTRS', -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
+         KC = N*( N+1 ) / 2 + 1
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         KC = KC - K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL SSWAP( 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 SGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL SSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K-1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K-1 )
+     $         CALL SSWAP( 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 SGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+            CALL SGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+     $                 B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+K-2 )
+            AKM1 = AP( KC-1 ) / AKM1K
+            AK = AP( KC+K-1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / AKM1K
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            KC = KC - K + 1
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + K
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+     $                  AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + 2*K + 1
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL SSWAP( 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 SGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+     $                    LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL SSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
+            KC = KC + N - K + 1
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL SSWAP( 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 SGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+     $                    LDB, B( K+2, 1 ), LDB )
+               CALL SGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+     $                    B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+1 )
+            AKM1 = AP( KC ) / AKM1K
+            AK = AP( KC+N-K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / AKM1K
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            KC = KC + 2*( N-K ) + 1
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         KC = KC - ( N-K+1 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL SSWAP( 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 SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+               CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
+     $                     LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC - ( N-K+2 )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSPTRS
+*
+      END
diff --git a/SRC/sstebz.f b/SRC/sstebz.f
new file mode 100644
index 00000000..306f24e1
--- /dev/null
+++ b/SRC/sstebz.f
@@ -0,0 +1,651 @@
+      SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
+     $                   M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*     8-18-00:  Increase FUDGE factor for T3E (eca)
+*
+*     .. Scalar Arguments ..
+      CHARACTER          ORDER, RANGE
+      INTEGER            IL, INFO, IU, M, N, NSPLIT
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEBZ computes the eigenvalues of a symmetric tridiagonal
+*  matrix T.  The user may ask for all eigenvalues, all eigenvalues
+*  in the half-open interval (VL, VU], or the IL-th through IU-th
+*  eigenvalues.
+*
+*  To avoid overflow, the matrix must be scaled so that its
+*  largest element is no greater than overflow**(1/2) *
+*  underflow**(1/4) in absolute value, and for greatest
+*  accuracy, it should not be much smaller than that.
+*
+*  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+*  Matrix", Report CS41, Computer Science Dept., Stanford
+*  University, July 21, 1966.
+*
+*  Arguments
+*  =========
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': ("All")   all eigenvalues will be found.
+*          = 'V': ("Value") all eigenvalues in the half-open interval
+*                           (VL, VU] will be found.
+*          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+*                           entire matrix) will be found.
+*
+*  ORDER   (input) CHARACTER*1
+*          = 'B': ("By Block") the eigenvalues will be grouped by
+*                              split-off block (see IBLOCK, ISPLIT) and
+*                              ordered from smallest to largest within
+*                              the block.
+*          = 'E': ("Entire matrix")
+*                              the eigenvalues for the entire matrix
+*                              will be ordered from smallest to
+*                              largest.
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal matrix T.  N >= 0.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues.  Eigenvalues less than or equal
+*          to VL, or greater than VU, will not be returned.  VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute tolerance for the eigenvalues.  An eigenvalue
+*          (or cluster) is considered to be located if it has been
+*          determined to lie in an interval whose width is ABSTOL or
+*          less.  If ABSTOL is less than or equal to zero, then ULP*|T|
+*          will be used, where |T| means the 1-norm of T.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+*  M       (output) INTEGER
+*          The actual number of eigenvalues found. 0 <= M <= N.
+*          (See also the description of INFO=2,3.)
+*
+*  NSPLIT  (output) INTEGER
+*          The number of diagonal blocks in the matrix T.
+*          1 <= NSPLIT <= N.
+*
+*  W       (output) REAL array, dimension (N)
+*          On exit, the first M elements of W will contain the
+*          eigenvalues.  (SSTEBZ may use the remaining N-M elements as
+*          workspace.)
+*
+*  IBLOCK  (output) INTEGER array, dimension (N)
+*          At each row/column j where E(j) is zero or small, the
+*          matrix T is considered to split into a block diagonal
+*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which
+*          block (from 1 to the number of blocks) the eigenvalue W(i)
+*          belongs.  (SSTEBZ may use the remaining N-M elements as
+*          workspace.)
+*
+*  ISPLIT  (output) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to ISPLIT(1),
+*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+*          etc., and the NSPLIT-th consists of rows/columns
+*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*          (Only the first NSPLIT elements will actually be used, but
+*          since the user cannot know a priori what value NSPLIT will
+*          have, N words must be reserved for ISPLIT.)
+*
+*  WORK    (workspace) REAL array, dimension (4*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  some or all of the eigenvalues failed to converge or
+*                were not computed:
+*                =1 or 3: Bisection failed to converge for some
+*                        eigenvalues; these eigenvalues are flagged by a
+*                        negative block number.  The effect is that the
+*                        eigenvalues may not be as accurate as the
+*                        absolute and relative tolerances.  This is
+*                        generally caused by unexpectedly inaccurate
+*                        arithmetic.
+*                =2 or 3: RANGE='I' only: Not all of the eigenvalues
+*                        IL:IU were found.
+*                        Effect: M < IU+1-IL
+*                        Cause:  non-monotonic arithmetic, causing the
+*                                Sturm sequence to be non-monotonic.
+*                        Cure:   recalculate, using RANGE='A', and pick
+*                                out eigenvalues IL:IU.  In some cases,
+*                                increasing the PARAMETER "FUDGE" may
+*                                make things work.
+*                = 4:    RANGE='I', and the Gershgorin interval
+*                        initially used was too small.  No eigenvalues
+*                        were computed.
+*                        Probable cause: your machine has sloppy
+*                                        floating-point arithmetic.
+*                        Cure: Increase the PARAMETER "FUDGE",
+*                              recompile, and try again.
+*
+*  Internal Parameters
+*  ===================
+*
+*  RELFAC  REAL, default = 2.0e0
+*          The relative tolerance.  An interval (a,b] lies within
+*          "relative tolerance" if  b-a < RELFAC*ulp*max(|a|,|b|),
+*          where "ulp" is the machine precision (distance from 1 to
+*          the next larger floating point number.)
+*
+*  FUDGE   REAL, default = 2
+*          A "fudge factor" to widen the Gershgorin intervals.  Ideally,
+*          a value of 1 should work, but on machines with sloppy
+*          arithmetic, this needs to be larger.  The default for
+*          publicly released versions should be large enough to handle
+*          the worst machine around.  Note that this has no effect
+*          on accuracy of the solution.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO, HALF
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   HALF = 1.0E0 / TWO )
+      REAL               FUDGE, RELFAC
+      PARAMETER          ( FUDGE = 2.1E0, RELFAC = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NCNVRG, TOOFEW
+      INTEGER            IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+     $                   IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
+     $                   ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
+     $                   NWU
+      REAL               ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
+     $                   TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUMMA( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH
+      EXTERNAL           LSAME, ILAENV, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAEBZ, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Decode RANGE
+*
+      IF( LSAME( RANGE, 'A' ) ) THEN
+         IRANGE = 1
+      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+         IRANGE = 2
+      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+         IRANGE = 3
+      ELSE
+         IRANGE = 0
+      END IF
+*
+*     Decode ORDER
+*
+      IF( LSAME( ORDER, 'B' ) ) THEN
+         IORDER = 2
+      ELSE IF( LSAME( ORDER, 'E' ) ) THEN
+         IORDER = 1
+      ELSE
+         IORDER = 0
+      END IF
+*
+*     Check for Errors
+*
+      IF( IRANGE.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IORDER.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( IRANGE.EQ.2 ) THEN
+         IF( VL.GE.VU ) INFO = -5
+      ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+     $          THEN
+         INFO = -6
+      ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
+     $          THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEBZ', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize error flags
+*
+      INFO = 0
+      NCNVRG = .FALSE.
+      TOOFEW = .FALSE.
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Simplifications:
+*
+      IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
+     $   IRANGE = 1
+*
+*     Get machine constants
+*     NB is the minimum vector length for vector bisection, or 0
+*     if only scalar is to be done.
+*
+      SAFEMN = SLAMCH( 'S' )
+      ULP = SLAMCH( 'P' )
+      RTOLI = ULP*RELFAC
+      NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
+      IF( NB.LE.1 )
+     $   NB = 0
+*
+*     Special Case when N=1
+*
+      IF( N.EQ.1 ) THEN
+         NSPLIT = 1
+         ISPLIT( 1 ) = 1
+         IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
+            M = 0
+         ELSE
+            W( 1 ) = D( 1 )
+            IBLOCK( 1 ) = 1
+            M = 1
+         END IF
+         RETURN
+      END IF
+*
+*     Compute Splitting Points
+*
+      NSPLIT = 1
+      WORK( N ) = ZERO
+      PIVMIN = ONE
+*
+CDIR$ NOVECTOR
+      DO 10 J = 2, N
+         TMP1 = E( J-1 )**2
+         IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
+            ISPLIT( NSPLIT ) = J - 1
+            NSPLIT = NSPLIT + 1
+            WORK( J-1 ) = ZERO
+         ELSE
+            WORK( J-1 ) = TMP1
+            PIVMIN = MAX( PIVMIN, TMP1 )
+         END IF
+   10 CONTINUE
+      ISPLIT( NSPLIT ) = N
+      PIVMIN = PIVMIN*SAFEMN
+*
+*     Compute Interval and ATOLI
+*
+      IF( IRANGE.EQ.3 ) THEN
+*
+*        RANGE='I': Compute the interval containing eigenvalues
+*                   IL through IU.
+*
+*        Compute Gershgorin interval for entire (split) matrix
+*        and use it as the initial interval
+*
+         GU = D( 1 )
+         GL = D( 1 )
+         TMP1 = ZERO
+*
+         DO 20 J = 1, N - 1
+            TMP2 = SQRT( WORK( J ) )
+            GU = MAX( GU, D( J )+TMP1+TMP2 )
+            GL = MIN( GL, D( J )-TMP1-TMP2 )
+            TMP1 = TMP2
+   20    CONTINUE
+*
+         GU = MAX( GU, D( N )+TMP1 )
+         GL = MIN( GL, D( N )-TMP1 )
+         TNORM = MAX( ABS( GL ), ABS( GU ) )
+         GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
+         GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
+*
+*        Compute Iteration parameters
+*
+         ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+     $           LOG( TWO ) ) + 2
+         IF( ABSTOL.LE.ZERO ) THEN
+            ATOLI = ULP*TNORM
+         ELSE
+            ATOLI = ABSTOL
+         END IF
+*
+         WORK( N+1 ) = GL
+         WORK( N+2 ) = GL
+         WORK( N+3 ) = GU
+         WORK( N+4 ) = GU
+         WORK( N+5 ) = GL
+         WORK( N+6 ) = GU
+         IWORK( 1 ) = -1
+         IWORK( 2 ) = -1
+         IWORK( 3 ) = N + 1
+         IWORK( 4 ) = N + 1
+         IWORK( 5 ) = IL - 1
+         IWORK( 6 ) = IU
+*
+         CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
+     $                WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+     $                IWORK, W, IBLOCK, IINFO )
+*
+         IF( IWORK( 6 ).EQ.IU ) THEN
+            WL = WORK( N+1 )
+            WLU = WORK( N+3 )
+            NWL = IWORK( 1 )
+            WU = WORK( N+4 )
+            WUL = WORK( N+2 )
+            NWU = IWORK( 4 )
+         ELSE
+            WL = WORK( N+2 )
+            WLU = WORK( N+4 )
+            NWL = IWORK( 2 )
+            WU = WORK( N+3 )
+            WUL = WORK( N+1 )
+            NWU = IWORK( 3 )
+         END IF
+*
+         IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+            INFO = 4
+            RETURN
+         END IF
+      ELSE
+*
+*        RANGE='A' or 'V' -- Set ATOLI
+*
+         TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+     $           ABS( D( N ) )+ABS( E( N-1 ) ) )
+*
+         DO 30 J = 2, N - 1
+            TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
+     $              ABS( E( J ) ) )
+   30    CONTINUE
+*
+         IF( ABSTOL.LE.ZERO ) THEN
+            ATOLI = ULP*TNORM
+         ELSE
+            ATOLI = ABSTOL
+         END IF
+*
+         IF( IRANGE.EQ.2 ) THEN
+            WL = VL
+            WU = VU
+         ELSE
+            WL = ZERO
+            WU = ZERO
+         END IF
+      END IF
+*
+*     Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
+*     NWL accumulates the number of eigenvalues .le. WL,
+*     NWU accumulates the number of eigenvalues .le. WU
+*
+      M = 0
+      IEND = 0
+      INFO = 0
+      NWL = 0
+      NWU = 0
+*
+      DO 70 JB = 1, NSPLIT
+         IOFF = IEND
+         IBEGIN = IOFF + 1
+         IEND = ISPLIT( JB )
+         IN = IEND - IOFF
+*
+         IF( IN.EQ.1 ) THEN
+*
+*           Special Case -- IN=1
+*
+            IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
+     $         NWL = NWL + 1
+            IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
+     $         NWU = NWU + 1
+            IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
+     $          D( IBEGIN )-PIVMIN ) ) THEN
+               M = M + 1
+               W( M ) = D( IBEGIN )
+               IBLOCK( M ) = JB
+            END IF
+         ELSE
+*
+*           General Case -- IN > 1
+*
+*           Compute Gershgorin Interval
+*           and use it as the initial interval
+*
+            GU = D( IBEGIN )
+            GL = D( IBEGIN )
+            TMP1 = ZERO
+*
+            DO 40 J = IBEGIN, IEND - 1
+               TMP2 = ABS( E( J ) )
+               GU = MAX( GU, D( J )+TMP1+TMP2 )
+               GL = MIN( GL, D( J )-TMP1-TMP2 )
+               TMP1 = TMP2
+   40       CONTINUE
+*
+            GU = MAX( GU, D( IEND )+TMP1 )
+            GL = MIN( GL, D( IEND )-TMP1 )
+            BNORM = MAX( ABS( GL ), ABS( GU ) )
+            GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
+            GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
+*
+*           Compute ATOLI for the current submatrix
+*
+            IF( ABSTOL.LE.ZERO ) THEN
+               ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
+            ELSE
+               ATOLI = ABSTOL
+            END IF
+*
+            IF( IRANGE.GT.1 ) THEN
+               IF( GU.LT.WL ) THEN
+                  NWL = NWL + IN
+                  NWU = NWU + IN
+                  GO TO 70
+               END IF
+               GL = MAX( GL, WL )
+               GU = MIN( GU, WU )
+               IF( GL.GE.GU )
+     $            GO TO 70
+            END IF
+*
+*           Set Up Initial Interval
+*
+            WORK( N+1 ) = GL
+            WORK( N+IN+1 ) = GU
+            CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+            NWL = NWL + IWORK( 1 )
+            NWU = NWU + IWORK( IN+1 )
+            IWOFF = M - IWORK( 1 )
+*
+*           Compute Eigenvalues
+*
+            ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+     $              LOG( TWO ) ) + 2
+            CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+     $                   D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+     $                   IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+     $                   IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+*           Copy Eigenvalues Into W and IBLOCK
+*           Use -JB for block number for unconverged eigenvalues.
+*
+            DO 60 J = 1, IOUT
+               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+*
+*              Flag non-convergence.
+*
+               IF( J.GT.IOUT-IINFO ) THEN
+                  NCNVRG = .TRUE.
+                  IB = -JB
+               ELSE
+                  IB = JB
+               END IF
+               DO 50 JE = IWORK( J ) + 1 + IWOFF,
+     $                 IWORK( J+IN ) + IWOFF
+                  W( JE ) = TMP1
+                  IBLOCK( JE ) = IB
+   50          CONTINUE
+   60       CONTINUE
+*
+            M = M + IM
+         END IF
+   70 CONTINUE
+*
+*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+*
+      IF( IRANGE.EQ.3 ) THEN
+         IM = 0
+         IDISCL = IL - 1 - NWL
+         IDISCU = NWU - IU
+*
+         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+            DO 80 JE = 1, M
+               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+                  IDISCL = IDISCL - 1
+               ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+                  IDISCU = IDISCU - 1
+               ELSE
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+   80       CONTINUE
+            M = IM
+         END IF
+         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+*
+*           Code to deal with effects of bad arithmetic:
+*           Some low eigenvalues to be discarded are not in (WL,WLU],
+*           or high eigenvalues to be discarded are not in (WUL,WU]
+*           so just kill off the smallest IDISCL/largest IDISCU
+*           eigenvalues, by simply finding the smallest/largest
+*           eigenvalue(s).
+*
+*           (If N(w) is monotone non-decreasing, this should never
+*               happen.)
+*
+            IF( IDISCL.GT.0 ) THEN
+               WKILL = WU
+               DO 100 JDISC = 1, IDISCL
+                  IW = 0
+                  DO 90 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                   ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+   90             CONTINUE
+                  IBLOCK( IW ) = 0
+  100          CONTINUE
+            END IF
+            IF( IDISCU.GT.0 ) THEN
+*
+               WKILL = WL
+               DO 120 JDISC = 1, IDISCU
+                  IW = 0
+                  DO 110 JE = 1, M
+                     IF( IBLOCK( JE ).NE.0 .AND.
+     $                   ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
+                        IW = JE
+                        WKILL = W( JE )
+                     END IF
+  110             CONTINUE
+                  IBLOCK( IW ) = 0
+  120          CONTINUE
+            END IF
+            IM = 0
+            DO 130 JE = 1, M
+               IF( IBLOCK( JE ).NE.0 ) THEN
+                  IM = IM + 1
+                  W( IM ) = W( JE )
+                  IBLOCK( IM ) = IBLOCK( JE )
+               END IF
+  130       CONTINUE
+            M = IM
+         END IF
+         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+            TOOFEW = .TRUE.
+         END IF
+      END IF
+*
+*     If ORDER='B', do nothing -- the eigenvalues are already sorted
+*        by block.
+*     If ORDER='E', sort the eigenvalues from smallest to largest
+*
+      IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
+         DO 150 JE = 1, M - 1
+            IE = 0
+            TMP1 = W( JE )
+            DO 140 J = JE + 1, M
+               IF( W( J ).LT.TMP1 ) THEN
+                  IE = J
+                  TMP1 = W( J )
+               END IF
+  140       CONTINUE
+*
+            IF( IE.NE.0 ) THEN
+               ITMP1 = IBLOCK( IE )
+               W( IE ) = W( JE )
+               IBLOCK( IE ) = IBLOCK( JE )
+               W( JE ) = TMP1
+               IBLOCK( JE ) = ITMP1
+            END IF
+  150    CONTINUE
+      END IF
+*
+      INFO = 0
+      IF( NCNVRG )
+     $   INFO = INFO + 1
+      IF( TOOFEW )
+     $   INFO = INFO + 2
+      RETURN
+*
+*     End of SSTEBZ
+*
+      END
diff --git a/SRC/sstedc.f b/SRC/sstedc.f
new file mode 100644
index 00000000..444e659a
--- /dev/null
+++ b/SRC/sstedc.f
@@ -0,0 +1,406 @@
+      SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+     $                   LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPZ
+      INTEGER            INFO, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric tridiagonal matrix using the divide and conquer method.
+*  The eigenvectors of a full or band real symmetric matrix can also be
+*  found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
+*  matrix to tridiagonal form.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.  See SLAED3 for details.
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*          = 'V':  Compute eigenvectors of original dense symmetric
+*                  matrix also.  On entry, Z contains the orthogonal
+*                  matrix used to reduce the original matrix to
+*                  tridiagonal form.
+*
+*  N       (input) INTEGER
+*          The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D       (input/output) REAL 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) REAL array, dimension (N-1)
+*          On entry, the subdiagonal elements of the tridiagonal matrix.
+*          On exit, E has been destroyed.
+*
+*  Z       (input/output) REAL 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.
+*          If eigenvectors are desired, then LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) REAL 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 COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1 then LWORK must be at least
+*                         ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
+*                         where lg( N ) = smallest integer k such
+*                         that 2**k >= N.
+*          If COMPZ = 'I' and N > 1 then LWORK must be at least
+*                         ( 1 + 4*N + N**2 ).
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LWORK need
+*          only be max(1,2*(N-1)).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  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.
+*          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1 then LIWORK must be at least
+*                         ( 6 + 6*N + 5*N*lg N ).
+*          If COMPZ = 'I' and N > 1 then LIWORK must be at least
+*                         ( 3 + 5*N ).
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LIWORK
+*          need only be 1.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
+     $                   LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
+      REAL               EPS, ORGNRM, P, TINY
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANST
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLACPY, SLAED0, SLASCL, SLASET, SLASRT,
+     $                   SSTEQR, SSTERF, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, MOD, REAL, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR.
+     $         ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Compute the workspace requirements
+*
+         SMLSIZ = ILAENV( 9, 'SSTEDC', ' ', 0, 0, 0, 0 )
+         IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+         ELSE IF( N.LE.SMLSIZ ) THEN
+            LIWMIN = 1
+            LWMIN = 2*( N - 1 )
+         ELSE
+            LGN = INT( LOG( REAL( N ) )/LOG( TWO ) )
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            IF( ICOMPZ.EQ.1 ) THEN
+               LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
+               LIWMIN = 6 + 6*N + 5*N*LGN
+            ELSE IF( ICOMPZ.EQ.2 ) THEN
+               LWMIN = 1 + 4*N + N**2
+               LIWMIN = 3 + 5*N
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
+            INFO = -10
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEDC', -INFO )
+         RETURN
+      ELSE IF (LQUERY) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.NE.0 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     If the following conditional clause is removed, then the routine
+*     will use the Divide and Conquer routine to compute only the
+*     eigenvalues, which requires (3N + 3N**2) real workspace and
+*     (2 + 5N + 2N lg(N)) integer workspace.
+*     Since on many architectures SSTERF is much faster than any other
+*     algorithm for finding eigenvalues only, it is used here
+*     as the default. If the conditional clause is removed, then
+*     information on the size of workspace needs to be changed.
+*
+*     If COMPZ = 'N', use SSTERF to compute the eigenvalues.
+*
+      IF( ICOMPZ.EQ.0 ) THEN
+         CALL SSTERF( N, D, E, INFO )
+         GO TO 50
+      END IF
+*
+*     If N is smaller than the minimum divide size (SMLSIZ+1), then
+*     solve the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+*
+         CALL SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+      ELSE
+*
+*        If COMPZ = 'V', the Z matrix must be stored elsewhere for later
+*        use.
+*
+         IF( ICOMPZ.EQ.1 ) THEN
+            STOREZ = 1 + N*N
+         ELSE
+            STOREZ = 1
+         END IF
+*
+         IF( ICOMPZ.EQ.2 ) THEN
+            CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+         END IF
+*
+*        Scale.
+*
+         ORGNRM = SLANST( 'M', N, D, E )
+         IF( ORGNRM.EQ.ZERO )
+     $      GO TO 50
+*
+         EPS = SLAMCH( 'Epsilon' )
+*
+         START = 1
+*
+*        while ( START <= N )
+*
+   10    CONTINUE
+         IF( START.LE.N ) THEN
+*
+*           Let FINISH be the position of the next subdiagonal entry
+*           such that E( FINISH ) <= TINY or FINISH = N if no such
+*           subdiagonal exists.  The matrix identified by the elements
+*           between START and FINISH constitutes an independent
+*           sub-problem.
+*
+            FINISH = START
+   20       CONTINUE
+            IF( FINISH.LT.N ) THEN
+               TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
+     $                    SQRT( ABS( D( FINISH+1 ) ) )
+               IF( ABS( E( FINISH ) ).GT.TINY ) THEN
+                  FINISH = FINISH + 1
+                  GO TO 20
+               END IF
+            END IF
+*
+*           (Sub) Problem determined.  Compute its size and solve it.
+*
+            M = FINISH - START + 1
+            IF( M.EQ.1 ) THEN
+               START = FINISH + 1
+               GO TO 10
+            END IF
+            IF( M.GT.SMLSIZ ) THEN
+*
+*              Scale.
+*
+               ORGNRM = SLANST( 'M', M, D( START ), E( START ) )
+               CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
+     $                      INFO )
+               CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
+     $                      M-1, INFO )
+*
+               IF( ICOMPZ.EQ.1 ) THEN
+                  STRTRW = 1
+               ELSE
+                  STRTRW = START
+               END IF
+               CALL SLAED0( ICOMPZ, N, M, D( START ), E( START ),
+     $                      Z( STRTRW, START ), LDZ, WORK( 1 ), N,
+     $                      WORK( STOREZ ), IWORK, INFO )
+               IF( INFO.NE.0 ) THEN
+                  INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
+     $                   MOD( INFO, ( M+1 ) ) + START - 1
+                  GO TO 50
+               END IF
+*
+*              Scale back.
+*
+               CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
+     $                      INFO )
+*
+            ELSE
+               IF( ICOMPZ.EQ.1 ) THEN
+*
+*                 Since QR won't update a Z matrix which is larger than
+*                 the length of D, we must solve the sub-problem in a
+*                 workspace and then multiply back into Z.
+*
+                  CALL SSTEQR( 'I', M, D( START ), E( START ), WORK, M,
+     $                         WORK( M*M+1 ), INFO )
+                  CALL SLACPY( 'A', N, M, Z( 1, START ), LDZ,
+     $                         WORK( STOREZ ), N )
+                  CALL SGEMM( 'N', 'N', N, M, M, ONE,
+     $                        WORK( STOREZ ), N, WORK, M, ZERO,
+     $                        Z( 1, START ), LDZ )
+               ELSE IF( ICOMPZ.EQ.2 ) THEN
+                  CALL SSTEQR( 'I', M, D( START ), E( START ),
+     $                         Z( START, START ), LDZ, WORK, INFO )
+               ELSE
+                  CALL SSTERF( M, D( START ), E( START ), INFO )
+               END IF
+               IF( INFO.NE.0 ) THEN
+                  INFO = START*( N+1 ) + FINISH
+                  GO TO 50
+               END IF
+            END IF
+*
+            START = FINISH + 1
+            GO TO 10
+         END IF
+*
+*        endwhile
+*
+*        If the problem split any number of times, then the eigenvalues
+*        will not be properly ordered.  Here we permute the eigenvalues
+*        (and the associated eigenvectors) into ascending order.
+*
+         IF( M.NE.N ) THEN
+            IF( ICOMPZ.EQ.0 ) THEN
+*
+*              Use Quick Sort
+*
+               CALL SLASRT( 'I', N, D, INFO )
+*
+            ELSE
+*
+*              Use Selection Sort to minimize swaps of eigenvectors
+*
+               DO 40 II = 2, N
+                  I = II - 1
+                  K = I
+                  P = D( I )
+                  DO 30 J = II, N
+                     IF( D( J ).LT.P ) THEN
+                        K = J
+                        P = D( J )
+                     END IF
+   30             CONTINUE
+                  IF( K.NE.I ) THEN
+                     D( K ) = D( I )
+                     D( I ) = P
+                     CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+                  END IF
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+   50 CONTINUE
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of SSTEDC
+*
+      END
diff --git a/SRC/sstegr.f b/SRC/sstegr.f
new file mode 100644
index 00000000..583d2326
--- /dev/null
+++ b/SRC/sstegr.f
@@ -0,0 +1,180 @@
+      SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $           ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+     $           LIWORK, INFO )
+
+      IMPLICIT NONE
+*
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+      REAL             ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * )
+      REAL               Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEGR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  SSTEGR is a compatability wrapper around the improved SSTEMR routine.
+*  See SSTEMR for further details.
+*
+*  One important change is that the ABSTOL parameter no longer provides any
+*  benefit and hence is no longer used.
+*
+*  Note : SSTEGR and SSTEMR work only on machines which follow
+*  IEEE-754 floating-point standard in their handling of infinities and
+*  NaNs.  Normal execution may create these exceptiona values and hence
+*  may abort due to a floating point exception in environments which
+*  do not conform to the IEEE-754 standard.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) REAL array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          Unused.  Was the absolute error tolerance for the
+*          eigenvalues/eigenvectors in previous versions.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*          Supplying N columns is always safe.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  WORK    (workspace/output) REAL array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in SLARRE,
+*                if INFO = 2X, internal error in SLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by SLARRE or
+*                SLARRV, respectively.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL TRYRAC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL SSTEMR
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+      TRYRAC = .FALSE.
+
+      CALL SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*     End of SSTEGR
+*
+      END
diff --git a/SRC/sstein.f b/SRC/sstein.f
new file mode 100644
index 00000000..be2decc4
--- /dev/null
+++ b/SRC/sstein.f
@@ -0,0 +1,361 @@
+      SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDZ, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
+     $                   IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEIN computes the eigenvectors of a real symmetric tridiagonal
+*  matrix T corresponding to specified eigenvalues, using inverse
+*  iteration.
+*
+*  The maximum number of iterations allowed for each eigenvector is
+*  specified by an internal parameter MAXITS (currently set to 5).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input) REAL array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) REAL array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix
+*          T, in elements 1 to N-1.
+*
+*  M       (input) INTEGER
+*          The number of eigenvectors to be found.  0 <= M <= N.
+*
+*  W       (input) REAL array, dimension (N)
+*          The first M elements of W contain the eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block.  ( The output array
+*          W from SSTEBZ with ORDER = 'B' is expected here. )
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The submatrix indices associated with the corresponding
+*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
+*          the first submatrix from the top, =2 if W(i) belongs to
+*          the second submatrix, etc.  ( The output array IBLOCK
+*          from SSTEBZ is expected here. )
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*          ( The output array ISPLIT from SSTEBZ is expected here. )
+*
+*  Z       (output) REAL array, dimension (LDZ, M)
+*          The computed eigenvectors.  The eigenvector associated
+*          with the eigenvalue W(i) is stored in the i-th column of
+*          Z.  Any vector which fails to converge is set to its current
+*          iterate after MAXITS iterations.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (5*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  IFAIL   (output) INTEGER array, dimension (M)
+*          On normal exit, all elements of IFAIL are zero.
+*          If one or more eigenvectors fail to converge after
+*          MAXITS iterations, then their indices are stored in
+*          array IFAIL.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit.
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, then i eigenvectors failed to converge
+*               in MAXITS iterations.  Their indices are stored in
+*               array IFAIL.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXITS  INTEGER, default = 5
+*          The maximum number of iterations performed.
+*
+*  EXTRA   INTEGER, default = 2
+*          The number of iterations performed after norm growth
+*          criterion is satisfied, should be at least 1.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TEN, ODM3, ODM1
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1,
+     $                   ODM3 = 1.0E-3, ODM1 = 1.0E-1 )
+      INTEGER            MAXITS, EXTRA
+      PARAMETER          ( MAXITS = 5, EXTRA = 2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
+     $                   INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
+     $                   JBLK, JMAX, NBLK, NRMCHK
+      REAL               CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
+     $                   SCL, SEP, STPCRT, TOL, XJ, XJM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 )
+*     ..
+*     .. External Functions ..
+      INTEGER            ISAMAX
+      REAL               SASUM, SDOT, SLAMCH, SNRM2
+      EXTERNAL           ISAMAX, SASUM, SDOT, SLAMCH, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      DO 10 I = 1, M
+         IFAIL( I ) = 0
+   10 CONTINUE
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         DO 20 J = 2, M
+            IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
+               INFO = -6
+               GO TO 30
+            END IF
+            IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
+     $           THEN
+               INFO = -5
+               GO TO 30
+            END IF
+   20    CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      EPS = SLAMCH( 'Precision' )
+*
+*     Initialize seed for random number generator SLARNV.
+*
+      DO 40 I = 1, 4
+         ISEED( I ) = 1
+   40 CONTINUE
+*
+*     Initialize pointers.
+*
+      INDRV1 = 0
+      INDRV2 = INDRV1 + N
+      INDRV3 = INDRV2 + N
+      INDRV4 = INDRV3 + N
+      INDRV5 = INDRV4 + N
+*
+*     Compute eigenvectors of matrix blocks.
+*
+      J1 = 1
+      DO 160 NBLK = 1, IBLOCK( M )
+*
+*        Find starting and ending indices of block nblk.
+*
+         IF( NBLK.EQ.1 ) THEN
+            B1 = 1
+         ELSE
+            B1 = ISPLIT( NBLK-1 ) + 1
+         END IF
+         BN = ISPLIT( NBLK )
+         BLKSIZ = BN - B1 + 1
+         IF( BLKSIZ.EQ.1 )
+     $      GO TO 60
+         GPIND = B1
+*
+*        Compute reorthogonalization criterion and stopping criterion.
+*
+         ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
+         ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
+         DO 50 I = B1 + 1, BN - 1
+            ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
+     $               ABS( E( I ) ) )
+   50    CONTINUE
+         ORTOL = ODM3*ONENRM
+*
+         STPCRT = SQRT( ODM1 / BLKSIZ )
+*
+*        Loop through eigenvalues of block nblk.
+*
+   60    CONTINUE
+         JBLK = 0
+         DO 150 J = J1, M
+            IF( IBLOCK( J ).NE.NBLK ) THEN
+               J1 = J
+               GO TO 160
+            END IF
+            JBLK = JBLK + 1
+            XJ = W( J )
+*
+*           Skip all the work if the block size is one.
+*
+            IF( BLKSIZ.EQ.1 ) THEN
+               WORK( INDRV1+1 ) = ONE
+               GO TO 120
+            END IF
+*
+*           If eigenvalues j and j-1 are too close, add a relatively
+*           small perturbation.
+*
+            IF( JBLK.GT.1 ) THEN
+               EPS1 = ABS( EPS*XJ )
+               PERTOL = TEN*EPS1
+               SEP = XJ - XJM
+               IF( SEP.LT.PERTOL )
+     $            XJ = XJM + PERTOL
+            END IF
+*
+            ITS = 0
+            NRMCHK = 0
+*
+*           Get random starting vector.
+*
+            CALL SLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
+*
+*           Copy the matrix T so it won't be destroyed in factorization.
+*
+            CALL SCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
+            CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
+            CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
+*
+*           Compute LU factors with partial pivoting  ( PT = LU )
+*
+            TOL = ZERO
+            CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
+     $                   IINFO )
+*
+*           Update iteration count.
+*
+   70       CONTINUE
+            ITS = ITS + 1
+            IF( ITS.GT.MAXITS )
+     $         GO TO 100
+*
+*           Normalize and scale the righthand side vector Pb.
+*
+            SCL = BLKSIZ*ONENRM*MAX( EPS,
+     $            ABS( WORK( INDRV4+BLKSIZ ) ) ) /
+     $            SASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+*
+*           Solve the system LU = Pb.
+*
+            CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
+     $                   WORK( INDRV1+1 ), TOL, IINFO )
+*
+*           Reorthogonalize by modified Gram-Schmidt if eigenvalues are
+*           close enough.
+*
+            IF( JBLK.EQ.1 )
+     $         GO TO 90
+            IF( ABS( XJ-XJM ).GT.ORTOL )
+     $         GPIND = J
+            IF( GPIND.NE.J ) THEN
+               DO 80 I = GPIND, J - 1
+                  CTR = -SDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
+     $                  1 )
+                  CALL SAXPY( BLKSIZ, CTR, Z( B1, I ), 1,
+     $                        WORK( INDRV1+1 ), 1 )
+   80          CONTINUE
+            END IF
+*
+*           Check the infinity norm of the iterate.
+*
+   90       CONTINUE
+            JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            NRM = ABS( WORK( INDRV1+JMAX ) )
+*
+*           Continue for additional iterations after norm reaches
+*           stopping criterion.
+*
+            IF( NRM.LT.STPCRT )
+     $         GO TO 70
+            NRMCHK = NRMCHK + 1
+            IF( NRMCHK.LT.EXTRA+1 )
+     $         GO TO 70
+*
+            GO TO 110
+*
+*           If stopping criterion was not satisfied, update info and
+*           store eigenvector number in array ifail.
+*
+  100       CONTINUE
+            INFO = INFO + 1
+            IFAIL( INFO ) = J
+*
+*           Accept iterate as jth eigenvector.
+*
+  110       CONTINUE
+            SCL = ONE / SNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            IF( WORK( INDRV1+JMAX ).LT.ZERO )
+     $         SCL = -SCL
+            CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+  120       CONTINUE
+            DO 130 I = 1, N
+               Z( I, J ) = ZERO
+  130       CONTINUE
+            DO 140 I = 1, BLKSIZ
+               Z( B1+I-1, J ) = WORK( INDRV1+I )
+  140       CONTINUE
+*
+*           Save the shift to check eigenvalue spacing at next
+*           iteration.
+*
+            XJM = XJ
+*
+  150    CONTINUE
+  160 CONTINUE
+*
+      RETURN
+*
+*     End of SSTEIN
+*
+      END
diff --git a/SRC/sstemr.f b/SRC/sstemr.f
new file mode 100644
index 00000000..832bfd11
--- /dev/null
+++ b/SRC/sstemr.f
@@ -0,0 +1,644 @@
+      SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      LOGICAL            TRYRAC
+      INTEGER            IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
+      REAL               VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * )
+      REAL               Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEMR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  Depending on the number of desired eigenvalues, these are computed either
+*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
+*  computed by the use of various suitable L D L^T factorizations near clusters
+*  of close eigenvalues (referred to as RRRs, Relatively Robust
+*  Representations). An informal sketch of the algorithm follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  For more details, see:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*  Notes:
+*  1.SSTEMR works only on machines which follow IEEE-754
+*  floating-point standard in their handling of infinities and NaNs.
+*  This permits the use of efficient inner loops avoiding a check for
+*  zero divisors.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) REAL array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and can be computed with a workspace
+*          query by setting NZC = -1, see below.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  NZC     (input) INTEGER
+*          The number of eigenvectors to be held in the array Z.
+*          If RANGE = 'A', then NZC >= max(1,N).
+*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+*          If RANGE = 'I', then NZC >= IU-IL+1.
+*          If NZC = -1, then a workspace query is assumed; the
+*          routine calculates the number of columns of the array Z that
+*          are needed to hold the eigenvectors.
+*          This value is returned as the first entry of the Z array, and
+*          no error message related to NZC is issued by XERBLA.
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  TRYRAC  (input/output) LOGICAL
+*          If TRYRAC.EQ..TRUE., indicates that the code should check whether
+*          the tridiagonal matrix defines its eigenvalues to high relative
+*          accuracy.  If so, the code uses relative-accuracy preserving
+*          algorithms that might be (a bit) slower depending on the matrix.
+*          If the matrix does not define its eigenvalues to high relative
+*          accuracy, the code can uses possibly faster algorithms.
+*          If TRYRAC.EQ..FALSE., the code is not required to guarantee
+*          relatively accurate eigenvalues and can use the fastest possible
+*          techniques.
+*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
+*          does not define its eigenvalues to high relative accuracy.
+*
+*  WORK    (workspace/output) REAL array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in SLARRE,
+*                if INFO = 2X, internal error in SLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by SLARRE or
+*                SLARRV, respectively.
+*
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, FOUR, MINRGP
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
+     $                     FOUR = 4.0E0,
+     $                     MINRGP = 3.0E-3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+      INTEGER            I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
+     $                   IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
+     $                   INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
+     $                   ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
+     $                   NZCMIN, OFFSET, WBEGIN, WEND
+      REAL               BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
+     $                   RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
+     $                   THRESH, TMP, TNRM, WL, WU
+*     ..
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAE2, SLAEV2, SLARRC, SLARRE, SLARRJ,
+     $                   SLARRR, SLARRV, SLASRT, SSCAL, SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+      ZQUERY = ( NZC.EQ.-1 )
+
+*     SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
+*     In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
+*     Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
+      IF( WANTZ ) THEN
+         LWMIN = 18*N
+         LIWMIN = 10*N
+      ELSE
+*        need less workspace if only the eigenvalues are wanted
+         LWMIN = 12*N
+         LIWMIN = 8*N
+      ENDIF
+
+      WL = ZERO
+      WU = ZERO
+      IIL = 0
+      IIU = 0
+
+      IF( VALEIG ) THEN
+*        We do not reference VL, VU in the cases RANGE = 'I','A'
+*        The interval (WL, WU] contains all the wanted eigenvalues.
+*        It is either given by the user or computed in SLARRE.
+         WL = VL
+         WU = VU
+      ELSEIF( INDEIG ) THEN
+*        We do not reference IL, IU in the cases RANGE = 'V','A'
+         IIL = IL
+         IIU = IU
+      ENDIF
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
+         INFO = -7
+      ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
+         INFO = -8
+      ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -17
+      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -19
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( WANTZ .AND. ALLEIG ) THEN
+            NZCMIN = N
+         ELSE IF( WANTZ .AND. VALEIG ) THEN
+            CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+     $                            NZCMIN, ITMP, ITMP2, INFO )
+         ELSE IF( WANTZ .AND. INDEIG ) THEN
+            NZCMIN = IIU-IIL+1
+         ELSE
+*           WANTZ .EQ. FALSE.
+            NZCMIN = 0
+         ENDIF
+         IF( ZQUERY .AND. INFO.EQ.0 ) THEN
+            Z( 1,1 ) = NZCMIN
+         ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
+            INFO = -14
+         END IF
+      END IF
+
+      IF( INFO.NE.0 ) THEN
+*
+         CALL XERBLA( 'SSTEMR', -INFO )
+*
+         RETURN
+      ELSE IF( LQUERY .OR. ZQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Handle N = 0, 1, and 2 cases immediately
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            Z( 1, 1 ) = ONE
+            ISUPPZ(1) = 1
+            ISUPPZ(2) = 1
+         END IF
+         RETURN
+      END IF
+*
+      IF( N.EQ.2 ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL SLAE2( D(1), E(1), D(2), R1, R2 )
+         ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            CALL SLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
+         END IF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R2.GT.WL).AND.
+     $                  (R2.LE.WU)).OR.
+     $      (INDEIG.AND.(IIL.EQ.1)) ) THEN
+            M = M+1
+            W( M ) = R2
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = -SN
+               Z( 2, M ) = CS
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R1.GT.WL).AND.
+     $                  (R1.LE.WU)).OR.
+     $      (INDEIG.AND.(IIU.EQ.2)) ) THEN
+            M = M+1
+            W( M ) = R1
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = CS
+               Z( 2, M ) = SN
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         RETURN
+      END IF
+
+*     Continue with general N
+
+      INDGRS = 1
+      INDERR = 2*N + 1
+      INDGP = 3*N + 1
+      INDD = 4*N + 1
+      INDE2 = 5*N + 1
+      INDWRK = 6*N + 1
+*
+      IINSPL = 1
+      IINDBL = N + 1
+      IINDW = 2*N + 1
+      IINDWK = 3*N + 1
+*
+*     Scale matrix to allowable range, if necessary.
+*     The allowable range is related to the PIVMIN parameter; see the
+*     comments in SLARRD.  The preference for scaling small values
+*     up is heuristic; we expect users' matrices not to be close to the
+*     RMAX threshold.
+*
+      SCALE = ONE
+      TNRM = SLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         SCALE = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         SCALE = RMAX / TNRM
+      END IF
+      IF( SCALE.NE.ONE ) THEN
+         CALL SSCAL( N, SCALE, D, 1 )
+         CALL SSCAL( N-1, SCALE, E, 1 )
+         TNRM = TNRM*SCALE
+         IF( VALEIG ) THEN
+*           If eigenvalues in interval have to be found,
+*           scale (WL, WU] accordingly
+            WL = WL*SCALE
+            WU = WU*SCALE
+         ENDIF
+      END IF
+*
+*     Compute the desired eigenvalues of the tridiagonal after splitting
+*     into smaller subblocks if the corresponding off-diagonal elements
+*     are small
+*     THRESH is the splitting parameter for SLARRE
+*     A negative THRESH forces the old splitting criterion based on the
+*     size of the off-diagonal. A positive THRESH switches to splitting
+*     which preserves relative accuracy.
+*
+      IF( TRYRAC ) THEN
+*        Test whether the matrix warrants the more expensive relative approach.
+         CALL SLARRR( N, D, E, IINFO )
+      ELSE
+*        The user does not care about relative accurately eigenvalues
+         IINFO = -1
+      ENDIF
+*     Set the splitting criterion
+      IF (IINFO.EQ.0) THEN
+         THRESH = EPS
+      ELSE
+         THRESH = -EPS
+*        relative accuracy is desired but T does not guarantee it
+         TRYRAC = .FALSE.
+      ENDIF
+*
+      IF( TRYRAC ) THEN
+*        Copy original diagonal, needed to guarantee relative accuracy
+         CALL SCOPY(N,D,1,WORK(INDD),1)
+      ENDIF
+*     Store the squares of the offdiagonal values of T
+      DO 5 J = 1, N-1
+         WORK( INDE2+J-1 ) = E(J)**2
+ 5    CONTINUE
+
+*     Set the tolerance parameters for bisection
+      IF( .NOT.WANTZ ) THEN
+*        SLARRE computes the eigenvalues to full precision.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ELSE
+*        SLARRE computes the eigenvalues to less than full precision.
+*        SLARRV will refine the eigenvalue approximations, and we can
+*        need less accurate initial bisection in SLARRE.
+*        Note: these settings do only affect the subset case and SLARRE
+         RTOL1 = MAX( SQRT(EPS)*5.0E-2, FOUR * EPS )
+         RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
+      ENDIF
+      CALL SLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
+     $             WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+     $             IWORK( IINSPL ), M, W, WORK( INDERR ),
+     $             WORK( INDGP ), IWORK( IINDBL ),
+     $             IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+     $             WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = 10 + ABS( IINFO )
+         RETURN
+      END IF
+*     Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired
+*     part of the spectrum. All desired eigenvalues are contained in
+*     (WL,WU]
+
+
+      IF( WANTZ ) THEN
+*
+*        Compute the desired eigenvectors corresponding to the computed
+*        eigenvalues
+*
+         CALL SLARRV( N, WL, WU, D, E,
+     $                PIVMIN, IWORK( IINSPL ), M,
+     $                1, M, MINRGP, RTOL1, RTOL2,
+     $                W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+     $                IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
+     $                ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = 20 + ABS( IINFO )
+            RETURN
+         END IF
+      ELSE
+*        SLARRE computes eigenvalues of the (shifted) root representation
+*        SLARRV returns the eigenvalues of the unshifted matrix.
+*        However, if the eigenvectors are not desired by the user, we need
+*        to apply the corresponding shifts from SLARRE to obtain the
+*        eigenvalues of the original matrix.
+         DO 20 J = 1, M
+            ITMP = IWORK( IINDBL+J-1 )
+            W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 20      CONTINUE
+      END IF
+*
+
+      IF ( TRYRAC ) THEN
+*        Refine computed eigenvalues so that they are relatively accurate
+*        with respect to the original matrix T.
+         IBEGIN = 1
+         WBEGIN = 1
+         DO 39  JBLK = 1, IWORK( IINDBL+M-1 )
+            IEND = IWORK( IINSPL+JBLK-1 )
+            IN = IEND - IBEGIN + 1
+            WEND = WBEGIN - 1
+*           check if any eigenvalues have to be refined in this block
+ 36         CONTINUE
+            IF( WEND.LT.M ) THEN
+               IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
+                  WEND = WEND + 1
+                  GO TO 36
+               END IF
+            END IF
+            IF( WEND.LT.WBEGIN ) THEN
+               IBEGIN = IEND + 1
+               GO TO 39
+            END IF
+
+            OFFSET = IWORK(IINDW+WBEGIN-1)-1
+            IFIRST = IWORK(IINDW+WBEGIN-1)
+            ILAST = IWORK(IINDW+WEND-1)
+            RTOL2 = FOUR * EPS
+            CALL SLARRJ( IN,
+     $                   WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
+     $                   IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
+     $                   WORK( INDERR+WBEGIN-1 ),
+     $                   WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
+     $                   TNRM, IINFO )
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+ 39      CONTINUE
+      ENDIF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( SCALE.NE.ONE ) THEN
+         CALL SSCAL( M, ONE / SCALE, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in increasing order, then sort them,
+*     possibly along with eigenvectors.
+*
+      IF( NSPLIT.GT.1 ) THEN
+         IF( .NOT. WANTZ ) THEN
+            CALL SLASRT( 'I', M, W, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = 3
+               RETURN
+            END IF
+         ELSE
+            DO 60 J = 1, M - 1
+               I = 0
+               TMP = W( J )
+               DO 50 JJ = J + 1, M
+                  IF( W( JJ ).LT.TMP ) THEN
+                     I = JJ
+                     TMP = W( JJ )
+                  END IF
+ 50            CONTINUE
+               IF( I.NE.0 ) THEN
+                  W( I ) = W( J )
+                  W( J ) = TMP
+                  IF( WANTZ ) THEN
+                     CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+                     ITMP = ISUPPZ( 2*I-1 )
+                     ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
+                     ISUPPZ( 2*J-1 ) = ITMP
+                     ITMP = ISUPPZ( 2*I )
+                     ISUPPZ( 2*I ) = ISUPPZ( 2*J )
+                     ISUPPZ( 2*J ) = ITMP
+                  END IF
+               END IF
+ 60         CONTINUE
+         END IF
+      ENDIF
+*
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of SSTEMR
+*
+      END
diff --git a/SRC/ssteqr.f b/SRC/ssteqr.f
new file mode 100644
index 00000000..15a2d356
--- /dev/null
+++ b/SRC/ssteqr.f
@@ -0,0 +1,500 @@
+      SUBROUTINE SSTEQR( 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 ..
+      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEQR 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 SSYTRD or SSPTRD or SSBTRD 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) REAL 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) REAL array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix.
+*          On exit, E has been destroyed.
+*
+*  Z       (input/output) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE, TWO, THREE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   THREE = 3.0E0 )
+      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
+      REAL               ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
+     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST, SLAPY2
+      EXTERNAL           LSAME, SLAMCH, SLANST, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR,
+     $                   SLASRT, SSWAP, 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( 'SSTEQR', -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 = SLAMCH( 'E' )
+      EPS2 = EPS**2
+      SAFMIN = SLAMCH( '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 SLASET( '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 = SLANST( '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 SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+     $                INFO )
+      ELSE IF( ANORM.LT.SSFMIN ) THEN
+         ISCALE = 2
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL SLASCL( '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 SLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L+1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
+               WORK( L ) = C
+               WORK( N-1+L ) = S
+               CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ),
+     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
+            ELSE
+               CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 SLASR( '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 SLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L-1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
+               WORK( M ) = C
+               WORK( N-1+M ) = S
+               CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ),
+     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
+            ELSE
+               CALL SLAE2( 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 = SLAPY2( 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 SLARTG( 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 SLASR( '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 SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
+     $                N, INFO )
+      ELSE IF( ISCALE.EQ.2 ) THEN
+         CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL SLASCL( '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 SLASRT( '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 SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+            END IF
+  180    CONTINUE
+      END IF
+*
+  190 CONTINUE
+      RETURN
+*
+*     End of SSTEQR
+*
+      END
diff --git a/SRC/ssterf.f b/SRC/ssterf.f
new file mode 100644
index 00000000..f56d56ef
--- /dev/null
+++ b/SRC/ssterf.f
@@ -0,0 +1,364 @@
+      SUBROUTINE SSTERF( 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 ..
+      REAL               D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTERF 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE, TWO, THREE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+     $                   THREE = 3.0E0 )
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 30 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
+     $                   NMAXIT
+      REAL               ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
+     $                   OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
+     $                   SIGMA, SSFMAX, SSFMIN
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH, SLANST, SLAPY2
+      EXTERNAL           SLAMCH, SLANST, SLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAE2, SLASCL, SLASRT, 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( 'SSTERF', -INFO )
+         RETURN
+      END IF
+      IF( N.LE.1 )
+     $   RETURN
+*
+*     Determine the unit roundoff for this environment.
+*
+      EPS = SLAMCH( 'E' )
+      EPS2 = EPS**2
+      SAFMIN = SLAMCH( '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 = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
+      ISCALE = 0
+      IF( ANORM.GT.SSFMAX ) THEN
+         ISCALE = 1
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+     $                INFO )
+      ELSE IF( ANORM.LT.SSFMIN ) THEN
+         ISCALE = 2
+         CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL SLASCL( '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 SLAE2 to compute its
+*        eigenvalues.
+*
+         IF( M.EQ.L+1 ) THEN
+            RTE = SQRT( E( L ) )
+            CALL SLAE2( 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 = SLAPY2( 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 SLAE2 to compute its
+*        eigenvalues.
+*
+         IF( M.EQ.L-1 ) THEN
+            RTE = SQRT( E( L-1 ) )
+            CALL SLAE2( 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 = SLAPY2( 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 SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+      IF( ISCALE.EQ.2 )
+     $   CALL SLASCL( '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 SLASRT( 'I', N, D, INFO )
+*
+  180 CONTINUE
+      RETURN
+*
+*     End of SSTERF
+*
+      END
diff --git a/SRC/sstev.f b/SRC/sstev.f
new file mode 100644
index 00000000..fabd6e77
--- /dev/null
+++ b/SRC/sstev.f
@@ -0,0 +1,163 @@
+      SUBROUTINE SSTEV( JOBZ, N, D, E, 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
+      INTEGER            INFO, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEV computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric tridiagonal matrix A.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+*  E       (input/output) REAL array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A, stored in elements 1 to N-1 of E.
+*          On exit, the contents of E are destroyed.
+*
+*  Z       (output) REAL array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+*          eigenvectors of the matrix A, with the i-th column of Z
+*          holding the eigenvector associated with D(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (max(1,2*N-2))
+*          If JOBZ = 'N', WORK is not referenced.
+*
+*  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 E did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTZ
+      INTEGER            IMAX, ISCALE
+      REAL               BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TNRM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSTEQR, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      TNRM = SLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL SSCAL( N, SIGMA, D, 1 )
+         CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+      END IF
+*
+*     For eigenvalues only, call SSTERF.  For eigenvalues and
+*     eigenvectors, call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, D, E, INFO )
+      ELSE
+         CALL SSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, D, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of SSTEV
+*
+      END
diff --git a/SRC/sstevd.f b/SRC/sstevd.f
new file mode 100644
index 00000000..045ec9d9
--- /dev/null
+++ b/SRC/sstevd.f
@@ -0,0 +1,219 @@
+      SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+     $                   LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ
+      INTEGER            INFO, LDZ, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEVD computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric tridiagonal matrix. If eigenvectors are desired, it
+*  uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+*  E       (input/output) REAL array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A, stored in elements 1 to N-1 of E.
+*          On exit, the contents of E are destroyed.
+*
+*  Z       (output) REAL array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+*          eigenvectors of the matrix A, with the i-th column of Z
+*          holding the eigenvector associated with D(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) REAL array,
+*                                         dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If JOBZ  = 'N' or N <= 1 then LWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1 then LWORK must be at least
+*                         ( 1 + 4*N + N**2 ).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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.
+*          If JOBZ  = 'N' or N <= 1 then LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1 then LIWORK must be at least 3+5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  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 E did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTZ
+      INTEGER            ISCALE, LIWMIN, LWMIN
+      REAL               BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TNRM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSTEDC, SSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      LIWMIN = 1
+      LWMIN = 1
+      IF( N.GT.1 .AND. WANTZ ) THEN
+         LWMIN = 1 + 4*N + N**2
+         LIWMIN = 3 + 5*N
+      END IF
+*
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEVD', -INFO )
+         RETURN 
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN 
+*
+      IF( N.EQ.1 ) THEN
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN 
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      TNRM = SLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL SSCAL( N, SIGMA, D, 1 )
+         CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+      END IF
+*
+*     For eigenvalues only, call SSTERF.  For eigenvalues and
+*     eigenvectors, call SSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, D, E, INFO )
+      ELSE
+         CALL SSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK,
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL SSCAL( N, ONE / SIGMA, D, 1 )
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of SSTEVD
+*
+      END
diff --git a/SRC/sstevr.f b/SRC/sstevr.f
new file mode 100644
index 00000000..48c9ce22
--- /dev/null
+++ b/SRC/sstevr.f
@@ -0,0 +1,460 @@
+      SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+     $                   M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+     $                   LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEVR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T.  Eigenvalues and
+*  eigenvectors can be selected by specifying either a range of values
+*  or a range of indices for the desired eigenvalues.
+*
+*  Whenever possible, SSTEVR calls SSTEMR to compute the
+*  eigenspectrum using Relatively Robust Representations.  SSTEMR
+*  computes eigenvalues by the dqds algorithm, while orthogonal
+*  eigenvectors are computed from various "good" L D L^T representations
+*  (also known as Relatively Robust Representations). Gram-Schmidt
+*  orthogonalization is avoided as far as possible. More specifically,
+*  the various steps of the algorithm are as follows. For the i-th
+*  unreduced block of T,
+*     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
+*          is a relatively robust representation,
+*     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
+*         relative accuracy by the dqds algorithm,
+*     (c) If there is a cluster of close eigenvalues, "choose" sigma_i
+*         close to the cluster, and go to step (a),
+*     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
+*         compute the corresponding eigenvector by forming a
+*         rank-revealing twisted factorization.
+*  The desired accuracy of the output can be specified by the input
+*  parameter ABSTOL.
+*
+*  For more details, see "A new O(n^2) algorithm for the symmetric
+*  tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
+*  Computer Science Division Technical Report No. UCB//CSD-97-971,
+*  UC Berkeley, May 1997.
+*
+*
+*  Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested
+*  on machines which conform to the ieee-754 floating point standard.
+*  SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and
+*  when partial spectrum requests are made.
+*
+*  Normal execution of SSTEMR may create NaNs and infinities and
+*  hence may abort due to a floating point exception in environments
+*  which do not handle NaNs and infinities in the ieee standard default
+*  manner.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
+********** SSTEIN are called
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          On exit, D may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  E       (input/output) REAL array, dimension (max(1,N-1))
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A in elements 1 to N-1 of E.
+*          On exit, E may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*          If high relative accuracy is important, set ABSTOL to
+*          SLAMCH( 'Safe minimum' ).  Doing so will guarantee that
+*          eigenvalues are computed to high relative accuracy when
+*          possible in future releases.  The current code does not
+*          make any guarantees about high relative accuracy, but
+*          future releases will. See J. Barlow and J. Demmel,
+*          "Computing Accurate Eigensystems of Scaled Diagonally
+*          Dominant Matrices", LAPACK Working Note #7, for a discussion
+*          of which matrices define their eigenvalues to high relative
+*          accuracy.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal (and
+*          minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= 20*N.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal (and
+*          minimal) LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= 10*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  Internal error
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Ken Stanley, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Jason Riedy, Computer Science Division, University of
+*       California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ,
+     $                   TRYRAC
+      CHARACTER          ORDER
+      INTEGER            I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP,
+     $                   INDIWO, ISCALE, J, JJ, LIWMIN, LWMIN, NSPLIT
+      REAL               BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TMP1, TNRM, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SSCAL, SSTEBZ, SSTEMR, SSTEIN, SSTERF,
+     $                   SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*
+*     Test the input parameters.
+*
+      IEEEOK = ILAENV( 10, 'SSTEVR', 'N', 1, 2, 3, 4 )
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+      LWMIN = MAX( 1, 20*N )
+      LIWMIN = MAX(1, 10*N )
+*
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -14
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -17
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -19
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEVR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      VLL = VL
+      VUU = VU
+*
+      TNRM = SLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL SSCAL( N, SIGMA, D, 1 )
+         CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+
+*     Initialize indices into workspaces.  Note: These indices are used only
+*     if SSTERF or SSTEMR fail.
+
+*     IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
+*     stores the block indices of each of the M<=N eigenvalues.
+      INDIBL = 1
+*     IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
+*     stores the starting and finishing indices of each block.
+      INDISP = INDIBL + N
+*     IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+*     that corresponding to eigenvectors that fail to converge in
+*     SSTEIN.  This information is discarded; if any fail, the driver
+*     returns INFO > 0.
+      INDIFL = INDISP + N
+*     INDIWO is the offset of the remaining integer workspace.
+      INDIWO = INDISP + N
+*
+*     If all eigenvalues are desired, then
+*     call SSTERF or SSTEMR.  If this fails for some eigenvalue, then
+*     try SSTEBZ.
+*
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN
+         CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N, D, 1, W, 1 )
+            CALL SSTERF( N, W, WORK, INFO )
+         ELSE
+            CALL SCOPY( N, D, 1, WORK( N+1 ), 1 )
+            IF (ABSTOL .LE. TWO*N*EPS) THEN
+               TRYRAC = .TRUE.
+            ELSE
+               TRYRAC = .FALSE.
+            END IF
+            CALL SSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL,
+     $                   IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC,
+     $                   WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
+*
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 10
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+     $             NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK,
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+     $                Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ),
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   10 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 30 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 20 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   20       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               W( I ) = W( J )
+               W( J ) = TMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+            END IF
+   30    CONTINUE
+      END IF
+*
+*      Causes problems with tests 19 & 20:
+*      IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
+*
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of SSTEVR
+*
+      END
diff --git a/SRC/sstevx.f b/SRC/sstevx.f
new file mode 100644
index 00000000..dd57159d
--- /dev/null
+++ b/SRC/sstevx.f
@@ -0,0 +1,350 @@
+      SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+     $                   M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSTEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix A.  Eigenvalues and
+*  eigenvectors can be selected by specifying either a range of values
+*  or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) REAL array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.
+*          On exit, D may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  E       (input/output) REAL array, dimension (max(1,N-1))
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A in elements 1 to N-1 of E.
+*          On exit, E may be multiplied by a constant factor chosen
+*          to avoid over/underflow in computing the eigenvalues.
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less
+*          than or equal to zero, then  EPS*|T|  will be used in
+*          its place, where |T| is the 1-norm of the tridiagonal
+*          matrix.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge (INFO > 0), then that
+*          column of Z contains the latest approximation to the
+*          eigenvector, and the index of the eigenvector is returned
+*          in IFAIL.  If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) REAL array, dimension (5*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
+     $                   ISCALE, ITMP1, J, JJ, NSPLIT
+      REAL               BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+     $                   TMP1, TNRM, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH, SLANST
+      EXTERNAL           LSAME, SLAMCH, SLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SSCAL, SSTEBZ, SSTEIN, SSTEQR, SSTERF,
+     $                   SSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -14
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSTEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      IF ( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      ENDIF
+      TNRM = SLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / TNRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL SSCAL( N, SIGMA, D, 1 )
+         CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     If all eigenvalues are desired and ABSTOL is less than zero, then
+*     call SSTERF or SSTEQR.  If this fails for some eigenvalue, then
+*     try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL SCOPY( N, D, 1, W, 1 )
+         CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+         INDWRK = N + 1
+         IF( .NOT.WANTZ ) THEN
+            CALL SSTERF( N, W, WORK, INFO )
+         ELSE
+            CALL SSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 20
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDWRK = 1
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+     $             NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
+     $             WORK( INDWRK ), IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+     $                Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   20 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 40 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 30 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   30       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSTEVX
+*
+      END
diff --git a/SRC/ssycon.f b/SRC/ssycon.f
new file mode 100644
index 00000000..8118549c
--- /dev/null
+++ b/SRC/ssycon.f
@@ -0,0 +1,165 @@
+      SUBROUTINE SSYCON( 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      REAL               ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYCON 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 SSYTRF.
+*
+*  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) REAL array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by SSYTRF.
+*
+*  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 SSYTRF.
+*
+*  ANORM   (input) REAL
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) REAL
+*          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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, KASE
+      REAL               AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SSYTRS, 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( 'SSYCON', -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 SLACN2( 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 SSYTRS( 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 SSYCON
+*
+      END
diff --git a/SRC/ssyev.f b/SRC/ssyev.f
new file mode 100644
index 00000000..0e671c93
--- /dev/null
+++ b/SRC/ssyev.f
@@ -0,0 +1,211 @@
+      SUBROUTINE SSYEV( 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 ..
+      REAL               A( LDA, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYEV 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) REAL 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) REAL 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 SSYTRD 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
+     $                   LLWORK, LWKOPT, NB
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANSY
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLASCL, SORGTR, SSCAL, SSTEQR, SSTERF, SSYTRD,
+     $                   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, 'SSYTRD', 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( 'SSYEV ', -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 = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = SLANSY( '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 SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL SSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     SORGTR to generate the orthogonal matrix, then call SSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL SORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
+     $                LLWORK, IINFO )
+         CALL SSTEQR( 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 SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SSYEV
+*
+      END
diff --git a/SRC/ssyevd.f b/SRC/ssyevd.f
new file mode 100644
index 00000000..ead05c5e
--- /dev/null
+++ b/SRC/ssyevd.f
@@ -0,0 +1,273 @@
+      SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
+     $                   LIWORK, 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, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYEVD computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric matrix A. If eigenvectors are desired, it uses a
+*  divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Because of large use of BLAS of level 3, SSYEVD needs N**2 more
+*  workspace than SSYEVX.
+*
+*  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) REAL 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) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) REAL array,
+*                                         dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least 
+*                                                1 + 6*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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.
+*          If N <= 1,                LIWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i and JOBZ = 'N', then the algorithm failed
+*                to converge; i off-diagonal elements of an intermediate
+*                tridiagonal form did not converge to zero;
+*                if INFO = i and JOBZ = 'V', then the algorithm failed
+*                to compute an eigenvalue while working on the submatrix
+*                lying in rows and columns INFO/(N+1) through
+*                mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*  Modified by Francoise Tisseur, University of Tennessee.
+*
+*  Modified description of INFO. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+*
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
+     $                   LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
+      REAL               ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANSY
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACPY, SLASCL, SORMTR, SSCAL, SSTEDC, SSTERF,
+     $                   SSYTRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LIWMIN = 1
+            LWMIN = 1
+            LOPT = LWMIN
+            LIOPT = LIWMIN
+         ELSE
+            IF( WANTZ ) THEN
+               LIWMIN = 3 + 5*N
+               LWMIN = 1 + 6*N + 2*N**2
+            ELSE
+               LIWMIN = 1
+               LWMIN = 2*N + 1
+            END IF
+            LOPT = MAX( LWMIN, 2*N +
+     $                  ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) )
+            LIOPT = LIWMIN
+         END IF
+         WORK( 1 ) = LOPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN 
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = A( 1, 1 )
+         IF( WANTZ )
+     $      A( 1, 1 ) = ONE
+         RETURN 
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = SLANSY( '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 SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      INDWK2 = INDWRK + N*N
+      LLWRK2 = LWORK - INDWK2 + 1
+*
+      CALL SSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+*
+*     For eigenvalues only, call SSTERF.  For eigenvectors, first call
+*     SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+*     tridiagonal matrix, then call SORMTR to multiply it by the
+*     Householder transformations stored in A.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL SSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+         CALL SORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
+     $                WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
+         CALL SLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 )
+     $   CALL SSCAL( N, ONE / SIGMA, W, 1 )
+*
+      WORK( 1 ) = LOPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of SSYEVD
+*
+      END
diff --git a/SRC/ssyevr.f b/SRC/ssyevr.f
new file mode 100644
index 00000000..8f5ca484
--- /dev/null
+++ b/SRC/ssyevr.f
@@ -0,0 +1,562 @@
+      SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      REAL               A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYEVR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be
+*  selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  SSYEVR first reduces the matrix A to tridiagonal form T with a call
+*  to SSYTRD.  Then, whenever possible, SSYEVR calls SSTEMR to compute
+*  the eigenspectrum using Relatively Robust Representations.  SSTEMR
+*  computes eigenvalues by the dqds algorithm, while orthogonal
+*  eigenvectors are computed from various "good" L D L^T representations
+*  (also known as Relatively Robust Representations). Gram-Schmidt
+*  orthogonalization is avoided as far as possible. More specifically,
+*  the various steps of the algorithm are as follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  The desired accuracy of the output can be specified by the input
+*  parameter ABSTOL.
+*
+*  For more details, see SSTEMR's documentation and:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*
+*  Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested
+*  on machines which conform to the ieee-754 floating point standard.
+*  SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and
+*  when partial spectrum requests are made.
+*
+*  Normal execution of SSTEMR may create NaNs and infinities and
+*  hence may abort due to a floating point exception in environments
+*  which do not handle NaNs and infinities in the ieee standard default
+*  manner.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
+********** SSTEIN are called
+*
+*  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) REAL array, dimension (LDA, N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*          On exit, the lower triangle (if UPLO='L') or the upper
+*          triangle (if UPLO='U') of A, including the diagonal, is
+*          destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*          If high relative accuracy is important, set ABSTOL to
+*          SLAMCH( 'Safe minimum' ).  Doing so will guarantee that
+*          eigenvalues are computed to high relative accuracy when
+*          possible in future releases.  The current code does not
+*          make any guarantees about high relative accuracy, but
+*          future releases will. See J. Barlow and J. Demmel,
+*          "Computing Accurate Eigensystems of Scaled Diagonally
+*          Dominant Matrices", LAPACK Working Note #7, for a discussion
+*          of which matrices define their eigenvalues to high relative
+*          accuracy.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*          Supplying N columns is always safe.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+*  WORK    (workspace/output) REAL 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,26*N).
+*          For optimal efficiency, LWORK >= (NB+6)*N,
+*          where NB is the max of the blocksize for SSYTRD and SORMTR
+*          returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  Internal error
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Ken Stanley, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Jason Riedy, Computer Science Division, University of
+*       California at Berkeley, USA
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ, TRYRAC
+      CHARACTER          ORDER
+      INTEGER            I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
+     $                   INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
+     $                   INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
+     $                   LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANSY
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, SSTEIN,
+     $                   SSTERF, SSWAP, SSYTRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      IEEEOK = ILAENV( 10, 'SSYEVR', 'N', 1, 2, 3, 4 )
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+*
+      LWMIN = MAX( 1, 26*N )
+      LIWMIN = MAX( 1, 10*N )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+         NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) )
+         LWKOPT = MAX( ( NB+1 )*N, LWMIN )
+         WORK( 1 ) = LWKOPT
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYEVR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         WORK( 1 ) = 26
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = A( 1, 1 )
+         ELSE
+            IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+               M = 1
+               W( 1 ) = A( 1, 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF (VALEIG) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL SSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+
+*     Initialize indices into workspaces.  Note: The IWORK indices are
+*     used only if SSTERF or SSTEMR fail.
+
+*     WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
+*     elementary reflectors used in SSYTRD.
+      INDTAU = 1
+*     WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
+      INDD = INDTAU + N
+*     WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
+*     tridiagonal matrix from SSYTRD.
+      INDE = INDD + N
+*     WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
+*     -written by SSTEMR (the SSTERF path copies the diagonal to W).
+      INDDD = INDE + N
+*     WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
+*     -written while computing the eigenvalues in SSTERF and SSTEMR.
+      INDEE = INDDD + N
+*     INDWK is the starting offset of the left-over workspace, and
+*     LLWORK is the remaining workspace size.
+      INDWK = INDEE + N
+      LLWORK = LWORK - INDWK + 1
+
+*     IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
+*     stores the block indices of each of the M<=N eigenvalues.
+      INDIBL = 1
+*     IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
+*     stores the starting and finishing indices of each block.
+      INDISP = INDIBL + N
+*     IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+*     that corresponding to eigenvectors that fail to converge in
+*     SSTEIN.  This information is discarded; if any fail, the driver
+*     returns INFO > 0.
+      INDIFL = INDISP + N
+*     INDIWO is the offset of the remaining integer workspace.
+      INDIWO = INDISP + N
+
+*
+*     Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+     $             WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired
+*     then call SSTERF or SSTEMR and SORMTR.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
+*
+            IF (ABSTOL .LE. TWO*N*EPS) THEN
+               TRYRAC = .TRUE.
+            ELSE
+               TRYRAC = .FALSE.
+            END IF
+            CALL SSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
+     $                   VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
+     $                   TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
+     $                   INFO )
+*
+*
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by SSTEIN.
+*
+            IF( WANTZ .AND. INFO.EQ.0 ) THEN
+               INDWKN = INDE
+               LLWRKN = LWORK - INDWKN + 1
+               CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA,
+     $                      WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
+     $                      LLWRKN, IINFO )
+            END IF
+         END IF
+*
+*
+         IF( INFO.EQ.0 ) THEN
+*           Everything worked.  Skip SSTEBZ/SSTEIN.  IWORK(:) are
+*           undefined.
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*     Also call SSTEBZ and SSTEIN if SSTEMR fails.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
+     $                INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by SSTEIN.
+*
+         INDWKN = INDE
+         LLWRKN = LWORK - INDWKN + 1
+         CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+*  Jump here if SSTEMR/SSTEIN succeeded.
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.  Note: We do not sort the IFAIL portion of IWORK.
+*     It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do
+*     not return this detailed information to the user.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               W( I ) = W( J )
+               W( J ) = TMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+            END IF
+   50    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of SSYEVR
+*
+      END
diff --git a/SRC/ssyevx.f b/SRC/ssyevx.f
new file mode 100644
index 00000000..cb4acafa
--- /dev/null
+++ b/SRC/ssyevx.f
@@ -0,0 +1,433 @@
+      SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LWORK, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be
+*  selected by specifying either a range of values or a range of indices
+*  for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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) REAL array, dimension (LDA, N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*          On exit, the lower triangle (if UPLO='L') or the upper
+*          triangle (if UPLO='U') of A, including the diagonal, is
+*          destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) REAL 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 >= 1, when N <= 1;
+*          otherwise 8*N.
+*          For optimal efficiency, LWORK >= (NB+3)*N,
+*          where NB is the max of the blocksize for SSYTRD and SORMTR
+*          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.
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
+     $                   ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
+     $                   LWKOPT, NB, NSPLIT
+      REAL               ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANSY
+      EXTERNAL           LSAME, ILAENV, SLAMCH, SLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, SSTEBZ,
+     $                   SSTEIN, SSTEQR, SSTERF, SSWAP, SSYTRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWKMIN = 1
+            WORK( 1 ) = LWKMIN
+         ELSE
+            LWKMIN = 8*N
+            NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+            NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) )
+            LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+            WORK( 1 ) = LWKOPT
+         END IF
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+     $      INFO = -17
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = A( 1, 1 )
+         ELSE
+            IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+               M = 1
+               W( 1 ) = A( 1, 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      EPS = SLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL SSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      INDTAU = 1
+      INDE = INDTAU + N
+      INDD = INDE + N
+      INDWRK = INDD + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+     $             WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal to
+*     zero, then call SSTERF or SORGTR and SSTEQR.  If this fails for
+*     some eigenvalue, then try SSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+         INDEE = INDWRK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTERF( N, W, WORK( INDEE ), INFO )
+         ELSE
+            CALL SLACPY( 'A', N, N, A, LDA, Z, LDZ )
+            CALL SORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
+     $                   WORK( INDWRK ), LLWORK, IINFO )
+            CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+            CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+     $                   WORK( INDWRK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 30 I = 1, N
+                  IFAIL( I ) = 0
+   30          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 40
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWO = INDISP + N
+      CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+*        Apply orthogonal matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by SSTEIN.
+*
+         INDWKN = INDE
+         LLWRKN = LWORK - INDWKN + 1
+         CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   40 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 60 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 50 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   50       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   60    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SSYEVX
+*
+      END
diff --git a/SRC/ssygs2.f b/SRC/ssygs2.f
new file mode 100644
index 00000000..0f8deeb7
--- /dev/null
+++ b/SRC/ssygs2.f
@@ -0,0 +1,211 @@
+      SUBROUTINE SSYGS2( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYGS2 reduces a real symmetric-definite generalized eigenproblem
+*  to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
+*
+*  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` or L'*A*L.
+*
+*  B must have been previously factorized as U'*U or L*L' by SPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
+*          = 2 or 3: compute U*A*U' or L'*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored, and how B has been factorized.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) REAL array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by SPOTRF.
+*
+*  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 ..
+      REAL               ONE, HALF
+      PARAMETER          ( ONE = 1.0, HALF = 0.5 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K
+      REAL               AKK, BKK, CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SSCAL, SSYR2, STRMV, STRSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYGS2', -INFO )
+         RETURN
+      END IF
+*
+      IF( ITYPE.EQ.1 ) THEN
+         IF( UPPER ) THEN
+*
+*           Compute inv(U')*A*inv(U)
+*
+            DO 10 K = 1, N
+*
+*              Update the upper triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL SSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
+                  CT = -HALF*AKK
+                  CALL SAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL SSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
+     $                        B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
+                  CALL SAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL STRSV( UPLO, 'Transpose', 'Non-unit', N-K,
+     $                        B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute inv(L)*A*inv(L')
+*
+            DO 20 K = 1, N
+*
+*              Update the lower triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL SSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
+                  CT = -HALF*AKK
+                  CALL SAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL SSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
+     $                        B( K+1, K ), 1, A( K+1, K+1 ), LDA )
+                  CALL SAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL STRSV( UPLO, 'No transpose', 'Non-unit', N-K,
+     $                        B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
+               END IF
+   20       CONTINUE
+         END IF
+      ELSE
+         IF( UPPER ) THEN
+*
+*           Compute U*A*U'
+*
+            DO 30 K = 1, N
+*
+*              Update the upper triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL STRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
+     $                     LDB, A( 1, K ), 1 )
+               CT = HALF*AKK
+               CALL SAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL SSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
+     $                     A, LDA )
+               CALL SAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL SSCAL( K-1, BKK, A( 1, K ), 1 )
+               A( K, K ) = AKK*BKK**2
+   30       CONTINUE
+         ELSE
+*
+*           Compute L'*A*L
+*
+            DO 40 K = 1, N
+*
+*              Update the lower triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL STRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
+     $                     A( K, 1 ), LDA )
+               CT = HALF*AKK
+               CALL SAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL SSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
+     $                     LDB, A, LDA )
+               CALL SAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL SSCAL( K-1, BKK, A( K, 1 ), LDA )
+               A( K, K ) = AKK*BKK**2
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of SSYGS2
+*
+      END
diff --git a/SRC/ssygst.f b/SRC/ssygst.f
new file mode 100644
index 00000000..16060c09
--- /dev/null
+++ b/SRC/ssygst.f
@@ -0,0 +1,249 @@
+      SUBROUTINE SSYGST( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYGST reduces a real symmetric-definite generalized eigenproblem
+*  to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+*  B must have been previously factorized as U**T*U or L*L**T by SPOTRF.
+*
+*  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.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) REAL array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by SPOTRF.
+*
+*  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 ..
+      REAL               ONE, HALF
+      PARAMETER          ( ONE = 1.0, HALF = 0.5 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSYGS2, SSYMM, SSYR2K, STRMM, STRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'SSYGST', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ITYPE.EQ.1 ) THEN
+            IF( UPPER ) THEN
+*
+*              Compute inv(U')*A*inv(U)
+*
+               DO 10 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(k:n,k:n)
+*
+                  CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL STRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
+     $                           KB, N-K-KB+1, ONE, B( K, K ), LDB,
+     $                           A( K, K+KB ), LDA )
+                     CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+     $                           A( K, K+KB ), LDA )
+                     CALL SSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
+     $                            A( K, K+KB ), LDA, B( K, K+KB ), LDB,
+     $                            ONE, A( K+KB, K+KB ), LDA )
+                     CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+     $                           A( K, K+KB ), LDA )
+                     CALL STRSM( 'Right', UPLO, 'No transpose',
+     $                           'Non-unit', KB, N-K-KB+1, ONE,
+     $                           B( K+KB, K+KB ), LDB, A( K, K+KB ),
+     $                           LDA )
+                  END IF
+   10          CONTINUE
+            ELSE
+*
+*              Compute inv(L)*A*inv(L')
+*
+               DO 20 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(k:n,k:n)
+*
+                  CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL STRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
+     $                           N-K-KB+1, KB, ONE, B( K, K ), LDB,
+     $                           A( K+KB, K ), LDA )
+                     CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+     $                           A( K+KB, K ), LDA )
+                     CALL SSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
+     $                            -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
+     $                            LDB, ONE, A( K+KB, K+KB ), LDA )
+                     CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+     $                           A( K+KB, K ), LDA )
+                     CALL STRSM( 'Left', UPLO, 'No transpose',
+     $                           'Non-unit', N-K-KB+1, KB, ONE,
+     $                           B( K+KB, K+KB ), LDB, A( K+KB, K ),
+     $                           LDA )
+                  END IF
+   20          CONTINUE
+            END IF
+         ELSE
+            IF( UPPER ) THEN
+*
+*              Compute U*A*U'
+*
+               DO 30 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL STRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
+     $                        K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
+                  CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+                  CALL SSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
+     $                         A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
+     $                         LDA )
+                  CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+                  CALL STRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
+     $                        K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
+     $                        LDA )
+                  CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   30          CONTINUE
+            ELSE
+*
+*              Compute L'*A*L
+*
+               DO 40 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL STRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
+     $                        KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
+                  CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+                  CALL SSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
+     $                         A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
+     $                         LDA )
+                  CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+                  CALL STRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
+     $                        K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
+                  CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      RETURN
+*
+*     End of SSYGST
+*
+      END
diff --git a/SRC/ssygv.f b/SRC/ssygv.f
new file mode 100644
index 00000000..adc73def
--- /dev/null
+++ b/SRC/ssygv.f
@@ -0,0 +1,229 @@
+      SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, 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, ITYPE, LDA, LDB, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.
+*  Here A and B are assumed to be symmetric and B is also
+*  positive definite.
+*
+*  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.
+*
+*  A       (input/output) REAL array, dimension (LDA, N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*
+*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) REAL array, dimension (LDB, N)
+*          On entry, the symmetric positive definite matrix B.
+*          If UPLO = 'U', the leading N-by-N upper triangular part of B
+*          contains the upper triangular part of the matrix B.
+*          If UPLO = 'L', the leading N-by-N lower triangular part of B
+*          contains the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) REAL 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 SSYTRD 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:  SPOTRF or SSYEV returned an error code:
+*             <= N:  if INFO = i, SSYEV 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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKMIN, LWKOPT, NB, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPOTRF, SSYEV, SSYGST, STRMM, STRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKMIN = MAX( 1, 3*N - 1 )
+         NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYGV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL SPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of SSYGV
+*
+      END
diff --git a/SRC/ssygvd.f b/SRC/ssygvd.f
new file mode 100644
index 00000000..4984fffb
--- /dev/null
+++ b/SRC/ssygvd.f
@@ -0,0 +1,282 @@
+      SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+     $                   LWORK, IWORK, LIWORK, 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, LDA, LDB, LIWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
+*  B are assumed to be symmetric and B is also positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  A       (input/output) REAL array, dimension (LDA, N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*
+*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) REAL array, dimension (LDB, N)
+*          On entry, the symmetric matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  W       (output) REAL array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) REAL 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 N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
+*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK and IWORK
+*          arrays, returns these values as the first entries of the WORK
+*          and IWORK arrays, and no error message related to LWORK or
+*          LIWORK is issued by XERBLA.
+*
+*  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.
+*          If N <= 1,                LIWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK and IWORK arrays, and no error message related to
+*          LWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  SPOTRF or SSYEVD returned an error code:
+*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm
+*                    failed to converge; i off-diagonal elements of an
+*                    intermediate tridiagonal form did not converge to
+*                    zero;
+*                    if INFO = i and JOBZ = 'V', then the algorithm
+*                    failed to compute an eigenvalue while working on
+*                    the submatrix lying in rows and columns INFO/(N+1)
+*                    through mod(INFO,N+1);
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  Modified so that no backsubstitution is performed if SSYEVD fails to
+*  converge (NEIG in old code could be greater than N causing out of
+*  bounds reference to A - reported by Ralf Meyer).  Also corrected the
+*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LIOPT, LIWMIN, LOPT, LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPOTRF, SSYEVD, SSYGST, STRMM, STRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LIWMIN = 1
+         LWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LIWMIN = 3 + 5*N
+         LWMIN = 1 + 6*N + 2*N**2
+      ELSE
+         LIWMIN = 1
+         LWMIN = 2*N + 1
+      END IF
+      LOPT = LWMIN
+      LIOPT = LIWMIN
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LOPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL SPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK,
+     $             INFO )
+      LOPT = MAX( REAL( LOPT ), REAL( WORK( 1 ) ) )
+      LIOPT = MAX( REAL( LIOPT ), REAL( IWORK( 1 ) ) )
+*
+      IF( WANTZ .AND. INFO.EQ.0 ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LOPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of SSYGVD
+*
+      END
diff --git a/SRC/ssygvx.f b/SRC/ssygvx.f
new file mode 100644
index 00000000..bb2d118b
--- /dev/null
+++ b/SRC/ssygvx.f
@@ -0,0 +1,333 @@
+      SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
+     $                   VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
+     $                   LWORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
+      REAL               ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A
+*  and B are assumed to be symmetric and B is also positive definite.
+*  Eigenvalues and eigenvectors can be selected by specifying either a
+*  range of values or a range of indices for the desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A and B are stored;
+*          = 'L':  Lower triangle of A and B are stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix pencil (A,B).  N >= 0.
+*
+*  A       (input/output) REAL array, dimension (LDA, N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*
+*          On exit, the lower triangle (if UPLO='L') or the upper
+*          triangle (if UPLO='U') of A, including the diagonal, is
+*          destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) REAL array, dimension (LDA, N)
+*          On entry, the symmetric matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  VL      (input) REAL
+*  VU      (input) REAL
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) REAL
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*SLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) REAL array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) REAL array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace/output) REAL 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,8*N).
+*          For optimal efficiency, LWORK >= (NB+3)*N,
+*          where NB is the blocksize for SSYTRD 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.
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  SPOTRF or SSYEVX returned an error code:
+*             <= N:  if INFO = i, SSYEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKMIN, LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SPOTRF, SSYEVX, SSYGST, STRMM, STRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      UPPER = LSAME( UPLO, 'U' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF (INFO.EQ.0) THEN
+         IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKMIN = MAX( 1, 8*N )
+         NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYGVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL SPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
+     $             M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+     $                  LDB, Z, LDZ )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+     $                  LDB, Z, LDZ )
+         END IF
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SSYGVX
+*
+      END
diff --git a/SRC/ssyrfs.f b/SRC/ssyrfs.f
new file mode 100644
index 00000000..4ac6581e
--- /dev/null
+++ b/SRC/ssyrfs.f
@@ -0,0 +1,339 @@
+      SUBROUTINE SSYRFS( UPLO, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite, and
+*  provides error bounds and backward error estimates for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) REAL 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(1,N).
+*
+*  AF      (input) REAL array, dimension (LDAF,N)
+*          The factored form of the matrix A.  AF contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by SSYTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by SSYTRF.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by SSYTRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 )
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0E+0 )
+      REAL               THREE
+      PARAMETER          ( THREE = 3.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, SSYMV, SSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   40          CONTINUE
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = ABS( X( K, J ) )
+               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+               DO 60 I = K + 1, N
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                   INFO )
+            CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of SSYRFS
+*
+      END
diff --git a/SRC/ssysv.f b/SRC/ssysv.f
new file mode 100644
index 00000000..42f5e4b2
--- /dev/null
+++ b/SRC/ssysv.f
@@ -0,0 +1,174 @@
+      SUBROUTINE SSYSV( 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( * )
+      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYSV 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) REAL 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
+*          SSYTRF.
+*
+*  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 SSYTRF.  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) REAL 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) REAL 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
+*          SSYTRF.
+*
+*          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           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSYTRF, SSYTRS, 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, 'SSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYSV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SSYSV
+*
+      END
diff --git a/SRC/ssysvx.f b/SRC/ssysvx.f
new file mode 100644
index 00000000..04123b9b
--- /dev/null
+++ b/SRC/ssysvx.f
@@ -0,0 +1,300 @@
+      SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+     $                   LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYSVX uses the diagonal pivoting factorization to compute the
+*  solution to a real system of linear equations A * X = B,
+*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.
+*     The form of the factorization is
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices, and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AF and IPIV contain the factored form of
+*                  A.  AF and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) REAL 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(1,N).
+*
+*  AF      (input or output) REAL array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T.
+*
+*  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 details of the interchanges and the block structure
+*          of D, as determined by SSYTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by SSYTRF.
+*
+*  B       (input) REAL array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) REAL array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) REAL
+*          The estimate of the reciprocal condition number of the matrix
+*          A.  If RCOND is less than the machine precision (in
+*          particular, if RCOND = 0), the matrix is singular to working
+*          precision.  This condition is indicated by a return code of
+*          INFO > 0.
+*
+*  FERR    (output) REAL 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) REAL 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) REAL array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= max(1,3*N), and for best
+*          performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
+*          NB is the optimal blocksize for SSYTRF.
+*
+*          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 (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:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOFACT
+      INTEGER            LWKOPT, NB
+      REAL               ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      REAL               SLAMCH, SLANSY
+      EXTERNAL           ILAENV, LSAME, SLAMCH, SLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACPY, SSYCON, SSYRFS, SSYTRF, SSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKOPT = MAX( 1, 3*N )
+         IF( NOFACT ) THEN
+            NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = MAX( LWKOPT, N*NB )
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYSVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL SSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = SLANSY( 'I', UPLO, N, A, LDA, WORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL SSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK,
+     $             INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL SSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of SSYSVX
+*
+      END
diff --git a/SRC/ssytd2.f b/SRC/ssytd2.f
new file mode 100644
index 00000000..697b2ba0
--- /dev/null
+++ b/SRC/ssytd2.f
@@ -0,0 +1,247 @@
+      SUBROUTINE SSYTD2( 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 ..
+      REAL               A( LDA, * ), D( * ), E( * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYTD2 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) REAL 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) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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) REAL 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 ..
+      REAL               ONE, ZERO, HALF
+      PARAMETER          ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      REAL               ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SLARFG, SSYMV, SSYR2, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. 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( 'SSYTD2', -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 SLARFG( 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 SSYMV( 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*SDOT( I, TAU, 1, A( 1, I+1 ), 1 )
+               CALL SAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL SSYR2( 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 SLARFG( 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 SSYMV( 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*SDOT( N-I, TAU( I ), 1, A( I+1, I ),
+     $                 1 )
+               CALL SAXPY( 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 SSYR2( 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 SSYTD2
+*
+      END
diff --git a/SRC/ssytf2.f b/SRC/ssytf2.f
new file mode 100644
index 00000000..3dfd766b
--- /dev/null
+++ b/SRC/ssytf2.f
@@ -0,0 +1,521 @@
+      SUBROUTINE SSYTF2( 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( * )
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYTF2 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) REAL 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. SISNAN(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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
+      REAL               ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+     $                   ROWMAX, T, WK, WKM1, WKP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, SISNAN
+      INTEGER            ISAMAX
+      EXTERNAL           LSAME, ISAMAX, SISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, SSWAP, SSYR, 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( 'SSYTF2', -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 = ISAMAX( K-1, A( 1, K ), 1 )
+            COLMAX = ABS( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(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 + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+               ROWMAX = ABS( A( IMAX, JMAX ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = ISAMAX( 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 SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+               CALL SSWAP( 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 SSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+*              Store U(k) in column k
+*
+               CALL SSCAL( 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 + ISAMAX( N-K, A( K+1, K ), 1 )
+            COLMAX = ABS( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(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 + ISAMAX( IMAX-K, A( IMAX, K ), LDA )
+               ROWMAX = ABS( A( IMAX, JMAX ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + ISAMAX( 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 SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+               CALL SSWAP( 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 SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+     $                       A( K+1, K+1 ), LDA )
+*
+*                 Store L(k) in column K
+*
+                  CALL SSCAL( 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 SSYTF2
+*
+      END
diff --git a/SRC/ssytrd.f b/SRC/ssytrd.f
new file mode 100644
index 00000000..57a25239
--- /dev/null
+++ b/SRC/ssytrd.f
@@ -0,0 +1,294 @@
+      SUBROUTINE SSYTRD( 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 ..
+      REAL               A( LDA, * ), D( * ), E( * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYTRD 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) REAL 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) REAL array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) REAL 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) REAL array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLATRD, SSYR2K, SSYTD2, 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, 'SSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYTRD', -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, 'SSYTRD', 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, 'SSYTRD', 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 SLATRD( 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 SSYR2K( 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 SSYTD2( 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 SLATRD( 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 SSYR2K( 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 SSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+     $                TAU( I ), IINFO )
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of SSYTRD
+*
+      END
diff --git a/SRC/ssytrf.f b/SRC/ssytrf.f
new file mode 100644
index 00000000..38315d50
--- /dev/null
+++ b/SRC/ssytrf.f
@@ -0,0 +1,287 @@
+      SUBROUTINE SSYTRF( 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( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYTRF 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) REAL 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) REAL 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           SLASYF, SSYTF2, 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, 'SSYTRF', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'SSYTRF', -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, 'SSYTRF', 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 SLASYF;
+*        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 SLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
+     $                   IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns 1:k of A
+*
+            CALL SSYTF2( 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 SLASYF;
+*        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 SLASYF( 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 SSYTF2( 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 SSYTRF
+*
+      END
diff --git a/SRC/ssytri.f b/SRC/ssytri.f
new file mode 100644
index 00000000..2540a565
--- /dev/null
+++ b/SRC/ssytri.f
@@ -0,0 +1,312 @@
+      SUBROUTINE SSYTRI( 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( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYTRI 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
+*  SSYTRF.
+*
+*  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) REAL 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 SSYTRF.
+*
+*          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 SSYTRF.
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KP, KSTEP
+      REAL               AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT
+      EXTERNAL           LSAME, SDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SSWAP, SSYMV, 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( 'SSYTRI', -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 SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - SDOT( 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 SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+               A( K, K+1 ) = A( K, K+1 ) -
+     $                       SDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+               CALL SCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+               CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K+1 ), 1 )
+               A( K+1, K+1 ) = A( K+1, K+1 ) -
+     $                         SDOT( 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 SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+            CALL SSWAP( 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 SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - SDOT( 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 SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+               A( K, K-1 ) = A( K, K-1 ) -
+     $                       SDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+     $                       1 )
+               CALL SCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+               CALL SSYMV( 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 ) -
+     $                         SDOT( 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 SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+            CALL SSWAP( 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 SSYTRI
+*
+      END
diff --git a/SRC/ssytrs.f b/SRC/ssytrs.f
new file mode 100644
index 00000000..6195c177
--- /dev/null
+++ b/SRC/ssytrs.f
@@ -0,0 +1,369 @@
+      SUBROUTINE SSYTRS( 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( * )
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SSYTRS 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 SSYTRF.
+*
+*  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) REAL array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by SSYTRF.
+*
+*  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 SSYTRF.
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KP
+      REAL               AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SGER, SSCAL, SSWAP, 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( 'SSYTRS', -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 SSWAP( 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 SGER( 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 SSCAL( 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 SSWAP( 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 SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+            CALL SGER( 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 SGEMV( '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 SSWAP( 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 SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL SGEMV( '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 SSWAP( 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 SSWAP( 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 SGER( 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 SSCAL( 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 SSWAP( 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 SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+     $                    LDB, B( K+2, 1 ), LDB )
+               CALL SGER( 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 SGEMV( '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 SSWAP( 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 SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL SGEMV( '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 SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of SSYTRS
+*
+      END
diff --git a/SRC/stbcon.f b/SRC/stbcon.f
new file mode 100644
index 00000000..81ec16b6
--- /dev/null
+++ b/SRC/stbcon.f
@@ -0,0 +1,202 @@
+      SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, KD, LDAB, N
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STBCON estimates the reciprocal of the condition number of a
+*  triangular band matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  RCOND   (output) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLANTB
+      EXTERNAL           LSAME, ISAMAX, SLAMCH, SLANTB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATBS, SRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = SLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the norm of the inverse of A.
+*
+         AINVNM = ZERO
+         NORMIN = 'N'
+         IF( ONENRM ) THEN
+            KASE1 = 1
+         ELSE
+            KASE1 = 2
+         END IF
+         KASE = 0
+   10    CONTINUE
+         CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL SLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
+     $                      AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL SLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB,
+     $                      LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = ISAMAX( N, WORK, 1 )
+               XNORM = ABS( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL SRSCL( 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 STBCON
+*
+      END
diff --git a/SRC/stbrfs.f b/SRC/stbrfs.f
new file mode 100644
index 00000000..6a020c38
--- /dev/null
+++ b/SRC/stbrfs.f
@@ -0,0 +1,385 @@
+      SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, KD, LDAB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AB( LDAB, * ), B( LDB, * ), BERR( * ),
+     $                   FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STBRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular band
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by STBTRS or some other
+*  means before entering this routine.  STBRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          The solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANST
+      INTEGER            I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, STBMV, STBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = KD + 2
+      EPS = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A or A', depending on TRANS.
+*
+         CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL STBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ),
+     $               1 )
+         CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 30 I = MAX( 1, K-KD ), K
+                        WORK( I ) = WORK( I ) +
+     $                              ABS( AB( KD+1+I-K, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 50 I = MAX( 1, K-KD ), K - 1
+                        WORK( I ) = WORK( I ) +
+     $                              ABS( AB( KD+1+I-K, K ) )*XK
+   50                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 70 I = K, MIN( N, K+KD )
+                        WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 90 I = K + 1, MIN( N, K+KD )
+                        WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+   90                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A')*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = MAX( 1, K-KD ), K
+                        S = S + ABS( AB( KD+1+I-K, K ) )*
+     $                      ABS( X( I, J ) )
+  110                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 130 I = MAX( 1, K-KD ), K - 1
+                        S = S + ABS( AB( KD+1+I-K, K ) )*
+     $                      ABS( X( I, J ) )
+  130                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, MIN( N, K+KD )
+                        S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+  150                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 170 I = K + 1, MIN( N, K+KD )
+                        S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+  170                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL SLACN2( 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)').
+*
+               CALL STBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB,
+     $                     WORK( N+1 ), 1 )
+               DO 220 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  230          CONTINUE
+               CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB,
+     $                     WORK( N+1 ), 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of STBRFS
+*
+      END
diff --git a/SRC/stbtrs.f b/SRC/stbtrs.f
new file mode 100644
index 00000000..39e47d62
--- /dev/null
+++ b/SRC/stbtrs.f
@@ -0,0 +1,162 @@
+      SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STBTRS solves a triangular system of the form
+*
+*     A * X = B  or  A**T * X = B,
+*
+*  where A is a triangular band matrix of order N, and B is an
+*  N-by NRHS matrix.  A check is made to verify that A is nonsingular.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  A is upper triangular;
+*          = 'L':  A is lower triangular.
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form the system of equations:
+*          = 'N':  A * X = B  (No transpose)
+*          = 'T':  A**T * X = B  (Transpose)
+*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) REAL array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STBSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOUNIT = LSAME( DIAG, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            DO 10 INFO = 1, N
+               IF( AB( KD+1, INFO ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            DO 20 INFO = 1, N
+               IF( AB( 1, INFO ).EQ.ZERO )
+     $            RETURN
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve A * X = B  or  A' * X = B.
+*
+      DO 30 J = 1, NRHS
+         CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of STBTRS
+*
+      END
diff --git a/SRC/stgevc.f b/SRC/stgevc.f
new file mode 100644
index 00000000..3045c129
--- /dev/null
+++ b/SRC/stgevc.f
@@ -0,0 +1,1147 @@
+      SUBROUTINE STGEVC( 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( * )
+      REAL               P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*
+*  Purpose
+*  =======
+*
+*  STGEVC 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 SGGHRD + SHGEQZ.
+*
+*  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) REAL array, dimension (LDS,N)
+*          The upper quasi-triangular matrix S from a generalized Schur
+*          factorization, as computed by SHGEQZ.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of array S.  LDS >= max(1,N).
+*
+*  P       (input) REAL array, dimension (LDP,N)
+*          The upper triangular matrix P from a generalized Schur
+*          factorization, as computed by SHGEQZ.
+*          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) REAL 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 SHGEQZ).
+*          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) REAL 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 SHGEQZ).
+*
+*          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) REAL 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 ..
+      REAL               ZERO, ONE, SAFETY
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0,
+     $                   SAFETY = 1.0E+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
+      REAL               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 ..
+      REAL               BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
+     $                   SUMP( 2, 2 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SLABAD, SLACPY, SLAG2, SLALN2, 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( 'STGEVC', -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( 'STGEVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = IM
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Machine Constants
+*
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      BIG = ONE / SAFMIN
+      CALL SLABAD( SAFMIN, BIG )
+      ULP = SLAMCH( 'Epsilon' )*SLAMCH( '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 SLAG2( 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 SLALN2( .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 SGEMV( '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 SLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
+     $                      LDVL )
+               IBEG = 1
+            ELSE
+               CALL SLACPY( ' ', 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 SLAG2( 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 SLALN2( .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 STGEVC
+*
+      END
diff --git a/SRC/stgex2.f b/SRC/stgex2.f
new file mode 100644
index 00000000..9b0afe8c
--- /dev/null
+++ b/SRC/stgex2.f
@@ -0,0 +1,581 @@
+      SUBROUTINE STGEX2( 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 ..
+      REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGEX2 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 SGGES), 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension (MAX(1,LWORK)).
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          LWORK >=  MAX( 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 SCOPY by calls to SLASET, or by DO
+*  loops. Sven Hammarling, 1/5/02.
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+      REAL               TEN
+      PARAMETER          ( TEN = 1.0E+01 )
+      INTEGER            LDST
+      PARAMETER          ( LDST = 4 )
+      LOGICAL            WANDS
+      PARAMETER          ( WANDS = .TRUE. )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            STRONG, WEAK
+      INTEGER            I, IDUM, LINFO, M
+      REAL               BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
+     $                   F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IWORK( LDST )
+      REAL               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 ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SGEQR2, SGERQ2, SLACPY, SLAGV2, SLARTG,
+     $                   SLASET, SLASSQ, SORG2R, SORGR2, SORM2R, SORMR2,
+     $                   SROT, SSCAL, STGSY2
+*     ..
+*     .. 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( N*M, M*M*2 ) ) THEN
+         INFO = -16
+         WORK( 1 ) = MAX( N*M, M*M*2 )
+         RETURN
+      END IF
+*
+      WEAK = .FALSE.
+      STRONG = .FALSE.
+*
+*     Make a local copy of selected block
+*
+      CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
+      CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
+      CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
+      CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
+*
+*     Compute threshold for testing acceptance of swapping.
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      DSCALE = ZERO
+      DSUM = ONE
+      CALL SLACPY( 'Full', M, M, S, LDST, WORK, M )
+      CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+      CALL SLACPY( 'Full', M, M, T, LDST, WORK, M )
+      CALL SLASSQ( 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 SLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
+         IR( 2, 1 ) = -IR( 1, 2 )
+         IR( 2, 2 ) = IR( 1, 1 )
+         CALL SROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         CALL SROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         IF( SA.GE.SB ) THEN
+            CALL SLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+     $                   DDUM )
+         ELSE
+            CALL SLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+     $                   DDUM )
+         END IF
+         CALL SROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
+     $              LI( 2, 1 ) )
+         CALL SROT( 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 SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+     $                   M )
+            CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+     $                  WORK, M )
+            CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            DSCALE = ZERO
+            DSUM = ONE
+            CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+            CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+     $                   M )
+            CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+     $                  WORK, M )
+            CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+            SS = DSCALE*SQRT( DSUM )
+            STRONG = SS.LE.THRESH
+            IF( .NOT.STRONG )
+     $         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 SROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         CALL SROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         CALL SROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
+     $              LI( 1, 1 ), LI( 2, 1 ) )
+         CALL SROT( 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 SROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
+     $                 IR( 2, 1 ) )
+         IF( WANTQ )
+     $      CALL SROT( 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 SLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
+         CALL SLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
+     $                IR( N2+1, N1+1 ), LDST )
+         CALL STGSY2( '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 SSCAL( N1, -ONE, LI( 1, I ), 1 )
+            LI( N1+I, I ) = SCALE
+   10    CONTINUE
+         CALL SGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL SORG2R( 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 SGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL SORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+*
+*        Perform the swapping tentatively:
+*
+         CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+     $               WORK, M )
+         CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S,
+     $               LDST )
+         CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+     $               WORK, M )
+         CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T,
+     $               LDST )
+         CALL SLACPY( 'F', M, M, S, LDST, SCPY, LDST )
+         CALL SLACPY( 'F', M, M, T, LDST, TCPY, LDST )
+         CALL SLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
+         CALL SLACPY( '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 SGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL SORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK,
+     $                LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL SORMR2( '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 SLASSQ( 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 SGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL SORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST,
+     $                WORK, INFO )
+         CALL SORM2R( '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 SLASSQ( 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 SLACPY( 'F', M, M, SCPY, LDST, S, LDST )
+            CALL SLACPY( 'F', M, M, TCPY, LDST, T, LDST )
+            CALL SLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
+            CALL SLACPY( '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 SLASET( '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 SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+     $                   M )
+            CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+     $                  WORK, M )
+            CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            DSCALE = ZERO
+            DSUM = ONE
+            CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+            CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+     $                   M )
+            CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+     $                  WORK, M )
+            CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+            SS = DSCALE*SQRT( DSUM )
+            STRONG = ( SS.LE.THRESH )
+            IF( .NOT.STRONG )
+     $         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 SLASET( '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 SLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
+         CALL SLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
+         CALL SLASET( '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 SLAGV2( 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 SLAGV2( 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 SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ),
+     $               LDA, ZERO, WORK( M*M+1 ), N2 )
+         CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ),
+     $                LDA )
+         CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ),
+     $               LDB, ZERO, WORK( M*M+1 ), N2 )
+         CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ),
+     $                LDB )
+         CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
+     $               WORK( M*M+1 ), M )
+         CALL SLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
+         CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
+     $               T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+         CALL SLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
+         CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
+     $               T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+         CALL SLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
+         CALL SGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
+     $               WORK, M )
+         CALL SLACPY( 'Full', M, M, WORK, M, IR, LDST )
+*
+*        Accumulate transformations into Q and Z if requested.
+*
+         IF( WANTQ ) THEN
+            CALL SGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
+     $                  LDST, ZERO, WORK, N )
+            CALL SLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
+*
+         END IF
+*
+         IF( WANTZ ) THEN
+            CALL SGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
+     $                  LDST, ZERO, WORK, N )
+            CALL SLACPY( '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 SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+     $                  A( J1, I ), LDA, ZERO, WORK, M )
+            CALL SLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
+            CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+     $                  B( J1, I ), LDB, ZERO, WORK, M )
+            CALL SLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
+         END IF
+         I = J1 - 1
+         IF( I.GT.0 ) THEN
+            CALL SGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
+     $                  LDST, ZERO, WORK, I )
+            CALL SLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
+            CALL SGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
+     $                  LDST, ZERO, WORK, I )
+            CALL SLACPY( '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 STGEX2
+*
+      END
diff --git a/SRC/stgexc.f b/SRC/stgexc.f
new file mode 100644
index 00000000..fab2be4f
--- /dev/null
+++ b/SRC/stgexc.f
@@ -0,0 +1,440 @@
+      SUBROUTINE STGEXC( 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 ..
+      REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGEXC 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 SGGES), 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            HERE, LWMIN, NBF, NBL, NBNEXT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STGEX2, 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( 'STGEXC', -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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEX2( 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 STGEXC
+*
+      END
diff --git a/SRC/stgsen.f b/SRC/stgsen.f
new file mode 100644
index 00000000..9b2054a5
--- /dev/null
+++ b/SRC/stgsen.f
@@ -0,0 +1,722 @@
+      SUBROUTINE STGSEN( 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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
+     $                   M, N
+      REAL               PL, PR
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGSEN 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 SGGES), i.e. A is block upper
+*  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
+*  triangular.
+*
+*  STGSEN also computes the generalized eigenvalues
+*
+*              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
+*
+*  of the reordered matrix pair (A, B).
+*
+*  Optionally, STGSEN 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) REAL 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) REAL 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) REAL array, dimension (N)
+*  ALPHAI  (output) REAL array, dimension (N)
+*  BETA    (output) REAL 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) REAL 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) REAL 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) REAL
+*  PR      (output) REAL
+*          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) REAL 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) REAL 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 >=  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
+*  ===============
+*
+*  STGSEN 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 SLATDF), then the parameter
+*  IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
+*  (IJOB = 2 will be used)). See STGSYL 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 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
+     $                   WANTP
+      INTEGER            I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
+     $                   MN2, N1, N2
+      REAL               DSCALE, DSUM, EPS, RDSCAL, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      REAL               SLAMCH
+      EXTERNAL           SLAMCH
+*     ..
+*     .. 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( 'STGSEN', -INFO )
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( '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( 'STGSEN', -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 SLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
+               CALL SLASSQ( 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 STGEXC( 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 SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
+         CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
+     $                N1 )
+         CALL STGSYL( '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 SLASSQ( 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 SLASSQ( 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 STGSYL( '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 STGSYL( '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 SLACN2. 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 SLACN2( 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 STGSYL( '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 STGSYL( '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 SLACN2( 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 STGSYL( '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 STGSYL( '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 70 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 SLAG2( 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 80 I = 1, N
+                     A( K, I ) = -A( K, I )
+                     B( K, I ) = -B( K, I )
+                     Q( I, K ) = -Q( I, K )
+   80             CONTINUE
+               END IF
+*
+               ALPHAR( K ) = A( K, K )
+               ALPHAI( K ) = ZERO
+               BETA( K ) = B( K, K )
+*
+            END IF
+         END IF
+   70 CONTINUE
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of STGSEN
+*
+      END
diff --git a/SRC/stgsja.f b/SRC/stgsja.f
new file mode 100644
index 00000000..be29a7a4
--- /dev/null
+++ b/SRC/stgsja.f
@@ -0,0 +1,515 @@
+      SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
+     $                   LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV,
+     $                   Q, LDQ, WORK, NCYCLE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
+     $                   NCYCLE, P
+      REAL               TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), Q( LDQ, * ), U( LDU, * ),
+     $                   V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGSJA computes the generalized singular value decomposition (GSVD)
+*  of two real upper triangular (or trapezoidal) matrices A and B.
+*
+*  On entry, it is assumed that matrices A and B have the following
+*  forms, which may be obtained by the preprocessing subroutine SGGSVP
+*  from a general M-by-N matrix A and P-by-N matrix B:
+*
+*               N-K-L  K    L
+*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;
+*            L ( 0     0   A23 )
+*        M-K-L ( 0     0    0  )
+*
+*             N-K-L  K    L
+*     A =  K ( 0    A12  A13 ) if M-K-L < 0;
+*        M-K ( 0     0   A23 )
+*
+*             N-K-L  K    L
+*     B =  L ( 0     0   B13 )
+*        P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.
+*
+*  On exit,
+*
+*              U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),
+*
+*  where U, V and Q are orthogonal matrices, Z' denotes the transpose
+*  of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
+*  ``diagonal'' matrices, which are of the following structures:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                    K  L
+*         D2 = L   ( 0  S )
+*              P-L ( 0  0 )
+*
+*                 N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 ) K
+*              L (  0    0   R22 ) L
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                 K M-K K+L-M
+*      D1 =   K ( I  0    0   )
+*           M-K ( 0  C    0   )
+*
+*                   K M-K K+L-M
+*      D2 =   M-K ( 0  S    0   )
+*           K+L-M ( 0  0    I   )
+*             P-L ( 0  0    0   )
+*
+*                 N-K-L  K   M-K  K+L-M
+* ( 0 R ) =    K ( 0    R11  R12  R13  )
+*            M-K ( 0     0   R22  R23  )
+*          K+L-M ( 0     0    0   R33  )
+*
+*  where
+*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*  S = diag( BETA(K+1),  ... , BETA(M) ),
+*  C**2 + S**2 = I.
+*
+*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
+*      (  0  R22 R23 )
+*  in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The computation of the orthogonal transformation matrices U, V or Q
+*  is optional.  These matrices may either be formed explicitly, or they
+*  may be postmultiplied into input matrices U1, V1, or Q1.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  U must contain an orthogonal matrix U1 on entry, and
+*                  the product U1*U is returned;
+*          = 'I':  U is initialized to the unit matrix, and the
+*                  orthogonal matrix U is returned;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  V must contain an orthogonal matrix V1 on entry, and
+*                  the product V1*V is returned;
+*          = 'I':  V is initialized to the unit matrix, and the
+*                  orthogonal matrix V is returned;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Q must contain an orthogonal matrix Q1 on entry, and
+*                  the product Q1*Q is returned;
+*          = 'I':  Q is initialized to the unit matrix, and the
+*                  orthogonal matrix Q is returned;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  K       (input) INTEGER
+*  L       (input) INTEGER
+*          K and L specify the subblocks in the input matrices A and B:
+*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
+*          of A and B, whose GSVD is going to be computed by STGSJA.
+*          See Further details.
+*
+*  A       (input/output) REAL array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
+*          matrix R or part of R.  See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) REAL array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
+*          a part of R.  See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) REAL
+*  TOLB    (input) REAL
+*          TOLA and TOLB are the convergence criteria for the Jacobi-
+*          Kogbetliantz iteration procedure. Generally, they are the
+*          same as used in the preprocessing step, say
+*              TOLA = max(M,N)*norm(A)*MACHEPS,
+*              TOLB = max(P,N)*norm(B)*MACHEPS.
+*
+*  ALPHA   (output) REAL array, dimension (N)
+*  BETA    (output) REAL array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = diag(C),
+*            BETA(K+1:K+L)  = diag(S),
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
+*          Furthermore, if K+L < N,
+*            ALPHA(K+L+1:N) = 0 and
+*            BETA(K+L+1:N)  = 0.
+*
+*  U       (input/output) REAL array, dimension (LDU,M)
+*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
+*          the orthogonal matrix returned by SGGSVP).
+*          On exit,
+*          if JOBU = 'I', U contains the orthogonal matrix U;
+*          if JOBU = 'U', U contains the product U1*U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (input/output) REAL array, dimension (LDV,P)
+*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
+*          the orthogonal matrix returned by SGGSVP).
+*          On exit,
+*          if JOBV = 'I', V contains the orthogonal matrix V;
+*          if JOBV = 'V', V contains the product V1*V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (input/output) REAL array, dimension (LDQ,N)
+*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
+*          the orthogonal matrix returned by SGGSVP).
+*          On exit,
+*          if JOBQ = 'I', Q contains the orthogonal matrix Q;
+*          if JOBQ = 'Q', Q contains the product Q1*Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) REAL array, dimension (2*N)
+*
+*  NCYCLE  (output) INTEGER
+*          The number of cycles required for convergence.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the procedure does not converge after MAXIT cycles.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXIT   INTEGER
+*          MAXIT specifies the total loops that the iterative procedure
+*          may take. If after MAXIT cycles, the routine fails to
+*          converge, we return INFO = 1.
+*
+*  Further Details
+*  ===============
+*
+*  STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
+*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
+*  matrix B13 to the form:
+*
+*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
+*
+*  where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
+*  of Z.  C1 and S1 are diagonal matrices satisfying
+*
+*                C1**2 + S1**2 = I,
+*
+*  and R1 is an L-by-L nonsingular upper triangular matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 40 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+*
+      LOGICAL            INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
+      INTEGER            I, J, KCYCLE
+      REAL               A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
+     $                   GAMMA, RWK, SNQ, SNU, SNV, SSMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SCOPY, SLAGS2, SLAPLL, SLARTG, SLASET, SROT,
+     $                   SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      INITU = LSAME( JOBU, 'I' )
+      WANTU = INITU .OR. LSAME( JOBU, 'U' )
+*
+      INITV = LSAME( JOBV, 'I' )
+      WANTV = INITV .OR. LSAME( JOBV, 'V' )
+*
+      INITQ = LSAME( JOBQ, 'I' )
+      WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -18
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -20
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -22
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STGSJA', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize U, V and Q, if necessary
+*
+      IF( INITU )
+     $   CALL SLASET( 'Full', M, M, ZERO, ONE, U, LDU )
+      IF( INITV )
+     $   CALL SLASET( 'Full', P, P, ZERO, ONE, V, LDV )
+      IF( INITQ )
+     $   CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+*     Loop until convergence
+*
+      UPPER = .FALSE.
+      DO 40 KCYCLE = 1, MAXIT
+*
+         UPPER = .NOT.UPPER
+*
+         DO 20 I = 1, L - 1
+            DO 10 J = I + 1, L
+*
+               A1 = ZERO
+               A2 = ZERO
+               A3 = ZERO
+               IF( K+I.LE.M )
+     $            A1 = A( K+I, N-L+I )
+               IF( K+J.LE.M )
+     $            A3 = A( K+J, N-L+J )
+*
+               B1 = B( I, N-L+I )
+               B3 = B( J, N-L+J )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A2 = A( K+I, N-L+J )
+                  B2 = B( I, N-L+J )
+               ELSE
+                  IF( K+J.LE.M )
+     $               A2 = A( K+J, N-L+I )
+                  B2 = B( J, N-L+I )
+               END IF
+*
+               CALL SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
+     $                      CSV, SNV, CSQ, SNQ )
+*
+*              Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
+*
+               IF( K+J.LE.M )
+     $            CALL SROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
+     $                       LDA, CSU, SNU )
+*
+*              Update I-th and J-th rows of matrix B: V'*B
+*
+               CALL SROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
+     $                    CSV, SNV )
+*
+*              Update (N-L+I)-th and (N-L+J)-th columns of matrices
+*              A and B: A*Q and B*Q
+*
+               CALL SROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
+     $                    A( 1, N-L+I ), 1, CSQ, SNQ )
+*
+               CALL SROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
+     $                    SNQ )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A( K+I, N-L+J ) = ZERO
+                  B( I, N-L+J ) = ZERO
+               ELSE
+                  IF( K+J.LE.M )
+     $               A( K+J, N-L+I ) = ZERO
+                  B( J, N-L+I ) = ZERO
+               END IF
+*
+*              Update orthogonal matrices U, V, Q, if desired.
+*
+               IF( WANTU .AND. K+J.LE.M )
+     $            CALL SROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
+     $                       SNU )
+*
+               IF( WANTV )
+     $            CALL SROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
+*
+               IF( WANTQ )
+     $            CALL SROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
+     $                       SNQ )
+*
+   10       CONTINUE
+   20    CONTINUE
+*
+         IF( .NOT.UPPER ) THEN
+*
+*           The matrices A13 and B13 were lower triangular at the start
+*           of the cycle, and are now upper triangular.
+*
+*           Convergence test: test the parallelism of the corresponding
+*           rows of A and B.
+*
+            ERROR = ZERO
+            DO 30 I = 1, MIN( L, M-K )
+               CALL SCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
+               CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
+               CALL SLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
+               ERROR = MAX( ERROR, SSMIN )
+   30       CONTINUE
+*
+            IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
+     $         GO TO 50
+         END IF
+*
+*        End of cycle loop
+*
+   40 CONTINUE
+*
+*     The algorithm has not converged after MAXIT cycles.
+*
+      INFO = 1
+      GO TO 100
+*
+   50 CONTINUE
+*
+*     If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
+*     Compute the generalized singular value pairs (ALPHA, BETA), and
+*     set the triangular matrix R to array A.
+*
+      DO 60 I = 1, K
+         ALPHA( I ) = ONE
+         BETA( I ) = ZERO
+   60 CONTINUE
+*
+      DO 70 I = 1, MIN( L, M-K )
+*
+         A1 = A( K+I, N-L+I )
+         B1 = B( I, N-L+I )
+*
+         IF( A1.NE.ZERO ) THEN
+            GAMMA = B1 / A1
+*
+*           change sign if necessary
+*
+            IF( GAMMA.LT.ZERO ) THEN
+               CALL SSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
+               IF( WANTV )
+     $            CALL SSCAL( P, -ONE, V( 1, I ), 1 )
+            END IF
+*
+            CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
+     $                   RWK )
+*
+            IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
+               CALL SSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
+     $                     LDA )
+            ELSE
+               CALL SSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
+     $                     LDB )
+               CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                     LDA )
+            END IF
+*
+         ELSE
+*
+            ALPHA( K+I ) = ZERO
+            BETA( K+I ) = ONE
+            CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                  LDA )
+*
+         END IF
+*
+   70 CONTINUE
+*
+*     Post-assignment
+*
+      DO 80 I = M + 1, K + L
+         ALPHA( I ) = ZERO
+         BETA( I ) = ONE
+   80 CONTINUE
+*
+      IF( K+L.LT.N ) THEN
+         DO 90 I = K + L + 1, N
+            ALPHA( I ) = ZERO
+            BETA( I ) = ZERO
+   90    CONTINUE
+      END IF
+*
+  100 CONTINUE
+      NCYCLE = KCYCLE
+      RETURN
+*
+*     End of STGSJA
+*
+      END
diff --git a/SRC/stgsna.f b/SRC/stgsna.f
new file mode 100644
index 00000000..f16b49b6
--- /dev/null
+++ b/SRC/stgsna.f
@@ -0,0 +1,580 @@
+      SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, JOB
+      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
+     $                   VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or eigenvectors of a matrix pair (A, B) in
+*  generalized real Schur canonical form (or of any matrix pair
+*  (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
+*  Z' denotes the transpose of Z.
+*
+*  (A, B) must be in generalized real Schur form (as returned by SGGES),
+*  i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
+*  blocks. B is upper triangular.
+*
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (DIF):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (DIF);
+*          = 'B': for both eigenvalues and eigenvectors (S and DIF).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the eigenpair corresponding to a real eigenvalue w(j),
+*          SELECT(j) must be set to .TRUE.. To select condition numbers
+*          corresponding to a complex conjugate pair of eigenvalues w(j)
+*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+*          set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the square matrix pair (A, B). N >= 0.
+*
+*  A       (input) REAL array, dimension (LDA,N)
+*          The upper quasi-triangular matrix A in the pair (A,B).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input) REAL array, dimension (LDB,N)
+*          The upper triangular matrix B in the pair (A,B).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  VL      (input) REAL array, dimension (LDVL,M)
+*          If JOB = 'E' or 'B', VL must contain left eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT. The eigenvectors must be stored in consecutive
+*          columns of VL, as returned by STGEVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL. LDVL >= 1.
+*          If JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) REAL array, dimension (LDVR,M)
+*          If JOB = 'E' or 'B', VR must contain right eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT. The eigenvectors must be stored in consecutive
+*          columns ov VR, as returned by STGEVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR. LDVR >= 1.
+*          If JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) REAL array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array. For a complex conjugate pair of eigenvalues two
+*          consecutive elements of S are set to the same value. Thus
+*          S(j), DIF(j), and the j-th columns of VL and VR all
+*          correspond to the same eigenpair (but not in general the
+*          j-th eigenpair, unless all eigenpairs are selected).
+*          If JOB = 'V', S is not referenced.
+*
+*  DIF     (output) REAL array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array. For a complex eigenvector two
+*          consecutive elements of DIF are set to the same value. If
+*          the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
+*          is set to 0; this can only occur when the true value would be
+*          very small anyway.
+*          If JOB = 'E', DIF is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S and DIF. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and DIF used to store
+*          the specified condition numbers; for each selected real
+*          eigenvalue one element is used, and for each selected complex
+*          conjugate pair of eigenvalues, two elements are used.
+*          If HOWMNY = 'A', M is set to N.
+*
+*  WORK    (workspace/output) REAL 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 JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N + 6)
+*          If JOB = 'E', IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          =0: Successful exit
+*          <0: If INFO = -i, the i-th argument had an illegal value
+*
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of a generalized eigenvalue
+*  w = (a, b) is defined as
+*
+*       S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
+*
+*  where u and v are the left and right eigenvectors of (A, B)
+*  corresponding to w; |z| denotes the absolute value of the complex
+*  number, and norm(u) denotes the 2-norm of the vector u.
+*  The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
+*  of the matrix pair (A, B). If both a and b equal zero, then (A B) is
+*  singular and S(I) = -1 is returned.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*       chord(w, lambda) <= EPS * norm(A, B) / S(I)
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number DIF(i) of right eigenvector u
+*  and left eigenvector v corresponding to the generalized eigenvalue w
+*  is defined as follows:
+*
+*  a) If the i-th eigenvalue w = (a,b) is real
+*
+*     Suppose U and V are orthogonal transformations such that
+*
+*                U'*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1
+*                                        ( 0  S22 ),( 0 T22 )  n-1
+*                                          1  n-1     1 n-1
+*
+*     Then the reciprocal condition number DIF(i) is
+*
+*                Difl((a, b), (S22, T22)) = sigma-min( Zl ),
+*
+*     where sigma-min(Zl) denotes the smallest singular value of the
+*     2(n-1)-by-2(n-1) matrix
+*
+*         Zl = [ kron(a, In-1)  -kron(1, S22) ]
+*              [ kron(b, In-1)  -kron(1, T22) ] .
+*
+*     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
+*     Kronecker product between the matrices X and Y.
+*
+*     Note that if the default method for computing DIF(i) is wanted
+*     (see SLATDF), then the parameter DIFDRI (see below) should be
+*     changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).
+*     See STGSYL for more details.
+*
+*  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
+*
+*     Suppose U and V are orthogonal transformations such that
+*
+*                U'*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2
+*                                       ( 0    S22 ),( 0    T22) n-2
+*                                         2    n-2     2    n-2
+*
+*     and (S11, T11) corresponds to the complex conjugate eigenvalue
+*     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
+*     that
+*
+*         U1'*S11*V1 = ( s11 s12 )   and U1'*T11*V1 = ( t11 t12 )
+*                      (  0  s22 )                    (  0  t22 )
+*
+*     where the generalized eigenvalues w = s11/t11 and
+*     conjg(w) = s22/t22.
+*
+*     Then the reciprocal condition number DIF(i) is bounded by
+*
+*         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
+*
+*     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
+*     Z1 is the complex 2-by-2 matrix
+*
+*              Z1 =  [ s11  -s22 ]
+*                    [ t11  -t22 ],
+*
+*     This is done by computing (using real arithmetic) the
+*     roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
+*     where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
+*     the determinant of X.
+*
+*     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
+*     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
+*
+*              Z2 = [ kron(S11', In-2)  -kron(I2, S22) ]
+*                   [ kron(T11', In-2)  -kron(I2, T22) ]
+*
+*     Note that if the default method for computing DIF is wanted (see
+*     SLATDF), then the parameter DIFDRI (see below) should be changed
+*     from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL
+*     for more details.
+*
+*  For each eigenvalue/vector specified by SELECT, DIF stores a
+*  Frobenius norm-based estimate of Difl.
+*
+*  An approximate error bound for the i-th computed eigenvector VL(i) or
+*  VR(i) is given by
+*
+*             EPS * norm(A, B) / DIF(i).
+*
+*  See ref. [2-3] for more details and further references.
+*
+*  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            DIFDRI
+      PARAMETER          ( DIFDRI = 3 )
+      REAL               ZERO, ONE, TWO, FOUR
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+     $                   FOUR = 4.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
+      INTEGER            I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
+      REAL               ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
+     $                   EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
+     $                   TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
+     $                   UHBVI
+*     ..
+*     .. Local Arrays ..
+      REAL               DUMMY( 1 ), DUMMY1( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT, SLAMCH, SLAPY2, SNRM2
+      EXTERNAL           LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMV, SLACPY, SLAG2, STGEXC, STGSYL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
+         INFO = -10
+      ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
+         INFO = -12
+      ELSE
+*
+*        Set M to the number of eigenpairs for which condition numbers
+*        are required, and test MM.
+*
+         IF( SOMCON ) THEN
+            M = 0
+            PAIR = .FALSE.
+            DO 10 K = 1, N
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+               ELSE
+                  IF( K.LT.N ) THEN
+                     IF( A( K+1, K ).EQ.ZERO ) THEN
+                        IF( SELECT( K ) )
+     $                     M = M + 1
+                     ELSE
+                        PAIR = .TRUE.
+                        IF( SELECT( K ) .OR. SELECT( K+1 ) )
+     $                     M = M + 2
+                     END IF
+                  ELSE
+                     IF( SELECT( N ) )
+     $                  M = M + 1
+                  END IF
+               END IF
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( N.EQ.0 ) THEN
+            LWMIN = 1
+         ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
+            LWMIN = 2*N*( N + 2 ) + 16
+         ELSE
+            LWMIN = N
+         END IF
+         WORK( 1 ) = LWMIN
+*
+         IF( MM.LT.M ) THEN
+            INFO = -15
+         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STGSNA', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      KS = 0
+      PAIR = .FALSE.
+*
+      DO 20 K = 1, N
+*
+*        Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+            GO TO 20
+         ELSE
+            IF( K.LT.N )
+     $         PAIR = A( K+1, K ).NE.ZERO
+         END IF
+*
+*        Determine whether condition numbers are required for the k-th
+*        eigenpair.
+*
+         IF( SOMCON ) THEN
+            IF( PAIR ) THEN
+               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+     $            GO TO 20
+            ELSE
+               IF( .NOT.SELECT( K ) )
+     $            GO TO 20
+            END IF
+         END IF
+*
+         KS = KS + 1
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            IF( PAIR ) THEN
+*
+*              Complex eigenvalue pair.
+*
+               RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
+     $                SNRM2( N, VR( 1, KS+1 ), 1 ) )
+               LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
+     $                SNRM2( N, VL( 1, KS+1 ), 1 ) )
+               CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
+     $                     ZERO, WORK, 1 )
+               TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               UHAV = TMPRR + TMPII
+               UHAVI = TMPIR - TMPRI
+               CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
+     $                     ZERO, WORK, 1 )
+               TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+               TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               UHBV = TMPRR + TMPII
+               UHBVI = TMPIR - TMPRI
+               UHAV = SLAPY2( UHAV, UHAVI )
+               UHBV = SLAPY2( UHBV, UHBVI )
+               COND = SLAPY2( UHAV, UHBV )
+               S( KS ) = COND / ( RNRM*LNRM )
+               S( KS+1 ) = S( KS )
+*
+            ELSE
+*
+*              Real eigenvalue.
+*
+               RNRM = SNRM2( N, VR( 1, KS ), 1 )
+               LNRM = SNRM2( N, VL( 1, KS ), 1 )
+               CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               UHAV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+     $                     WORK, 1 )
+               UHBV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+               COND = SLAPY2( UHAV, UHBV )
+               IF( COND.EQ.ZERO ) THEN
+                  S( KS ) = -ONE
+               ELSE
+                  S( KS ) = COND / ( RNRM*LNRM )
+               END IF
+            END IF
+         END IF
+*
+         IF( WANTDF ) THEN
+            IF( N.EQ.1 ) THEN
+               DIF( KS ) = SLAPY2( A( 1, 1 ), B( 1, 1 ) )
+               GO TO 20
+            END IF
+*
+*           Estimate the reciprocal condition number of the k-th
+*           eigenvectors.
+            IF( PAIR ) THEN
+*
+*              Copy the  2-by 2 pencil beginning at (A(k,k), B(k, k)).
+*              Compute the eigenvalue(s) at position K.
+*
+               WORK( 1 ) = A( K, K )
+               WORK( 2 ) = A( K+1, K )
+               WORK( 3 ) = A( K, K+1 )
+               WORK( 4 ) = A( K+1, K+1 )
+               WORK( 5 ) = B( K, K )
+               WORK( 6 ) = B( K+1, K )
+               WORK( 7 ) = B( K, K+1 )
+               WORK( 8 ) = B( K+1, K+1 )
+               CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
+     $                     DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
+               ALPRQT = ONE
+               C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
+               C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
+               ROOT1 = C1 + SQRT( C1*C1-4.0*C2 )
+               ROOT2 = C2 / ROOT1
+               ROOT1 = ROOT1 / TWO
+               COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
+            END IF
+*
+*           Copy the matrix (A, B) to the array WORK and swap the
+*           diagonal block beginning at A(k,k) to the (1,1) position.
+*
+            CALL SLACPY( 'Full', N, N, A, LDA, WORK, N )
+            CALL SLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+            IFST = K
+            ILST = 1
+*
+            CALL STGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
+     $                   DUMMY, 1, DUMMY1, 1, IFST, ILST,
+     $                   WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
+*
+            IF( IERR.GT.0 ) THEN
+*
+*              Ill-conditioned problem - swap rejected.
+*
+               DIF( KS ) = ZERO
+            ELSE
+*
+*              Reordering successful, solve generalized Sylvester
+*              equation for R and L,
+*                         A22 * R - L * A11 = A12
+*                         B22 * R - L * B11 = B12,
+*              and compute estimate of Difl((A11,B11), (A22, B22)).
+*
+               N1 = 1
+               IF( WORK( 2 ).NE.ZERO )
+     $            N1 = 2
+               N2 = N - N1
+               IF( N2.EQ.0 ) THEN
+                  DIF( KS ) = COND
+               ELSE
+                  I = N*N + 1
+                  IZ = 2*N*N + 1
+                  CALL STGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
+     $                         N, WORK, N, WORK( N1+1 ), N,
+     $                         WORK( N*N1+N1+I ), N, WORK( I ), N,
+     $                         WORK( N1+I ), N, SCALE, DIF( KS ),
+     $                         WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
+*
+                  IF( PAIR )
+     $               DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
+     $                           COND )
+               END IF
+            END IF
+            IF( PAIR )
+     $         DIF( KS+1 ) = DIF( KS )
+         END IF
+         IF( PAIR )
+     $      KS = KS + 1
+*
+   20 CONTINUE
+      WORK( 1 ) = LWMIN
+      RETURN
+*
+*     End of STGSNA
+*
+      END
diff --git a/SRC/stgsy2.f b/SRC/stgsy2.f
new file mode 100644
index 00000000..9fa0e16e
--- /dev/null
+++ b/SRC/stgsy2.f
@@ -0,0 +1,956 @@
+      SUBROUTINE STGSY2( 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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
+     $                   PQ
+      REAL               RDSCAL, RDSUM, SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGSY2 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 SLACON.
+*
+*  STGSY2 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
+*  STGSYL. 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. (SGECON 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL
+*          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) REAL
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by STGSYL, 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 STGSY2 is called by STGSYL.
+*
+*  RDSCAL  (input/output) REAL
+*          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 STGSY2 is called by
+*                STGSYL.
+*
+*  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 SCOPY by calls to SLASET.
+*  Sven Hammarling, 27/5/02.
+*
+*     .. Parameters ..
+      INTEGER            LDZ
+      PARAMETER          ( LDZ = 8 )
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
+     $                   K, MB, NB, P, Q, ZDIM
+      REAL               ALPHA, SCALOC
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IPIV( LDZ ), JPIV( LDZ )
+      REAL               RHS( LDZ ), Z( LDZ, LDZ )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMM, SGEMV, SGER, SGESC2,
+     $                   SGETC2, SSCAL, SLASET, SLATDF, 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( 'STGSY2', -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 SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 50 K = 1, N
+                           CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+   50                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL SLATDF( 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 SAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
+     $                           1 )
+                     CALL SAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
+     $                           1 )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL SAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL SAXPY( 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 SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 60 K = 1, N
+                           CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+   60                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL SLATDF( 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 SGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
+     $                          1, C( 1, JS ), LDC )
+                     CALL SGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
+     $                          1, F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL SAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL SAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
+     $                           F( IS, JE+1 ), LDF )
+                     CALL SAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL SAXPY( 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 SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 70 K = 1, N
+                           CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+   70                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL SLATDF( 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 SGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
+     $                           RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
+                     CALL SGEMV( '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 SGER( MB, N-JE, ONE, RHS( 3 ), 1,
+     $                          B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
+                     CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1,
+     $                          E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+*                 Build an 8-by-8 system Z * x = RHS
+*
+                  CALL SLASET( '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 SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+                     CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+                     K = K + MB
+                     II = II + MB
+   80             CONTINUE
+*
+*                 Solve Z * x = RHS
+*
+                  CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 90 K = 1, N
+                           CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+   90                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL SLATDF( 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 SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+                     CALL SCOPY( 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 SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
+     $                           C( 1, JS ), LDC )
+                     CALL SGEMM( '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 SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+     $                           MB, B( JS, JE+1 ), LDB, ONE,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL SGEMM( '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 = IWORK( I+1 ) - 1
+            MB = IE - IS + 1
+            DO 190 J = Q, P + 2, -1
+*
+               JS = IWORK( J )
+               JSP1 = JS + 1
+               JE = IWORK( J+1 ) - 1
+               NB = JE - JS + 1
+               ZDIM = MB*NB*2
+               IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+*                 Build a 2-by-2 system Z' * 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 SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 130 K = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( 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 SAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ),
+     $                           LDF )
+                     ALPHA = RHS( 2 )
+                     CALL SAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ),
+     $                           LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     ALPHA = -RHS( 1 )
+                     CALL SAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
+     $                           C( IE+1, JS ), 1 )
+                     ALPHA = -RHS( 2 )
+                     CALL SAXPY( 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 SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 140 K = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( 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 SAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
+     $                           F( IS, 1 ), LDF )
+                     CALL SAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
+     $                           F( IS, 1 ), LDF )
+                     CALL SAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
+     $                           F( IS, 1 ), LDF )
+                     CALL SAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
+     $                           F( IS, 1 ), LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     CALL SGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
+     $                          RHS( 1 ), 1, C( IE+1, JS ), LDC )
+                     CALL SGER( 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 SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 150 K = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( 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 SGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ),
+     $                          1, F( IS, 1 ), LDF )
+                     CALL SGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ),
+     $                          1, F( IS, 1 ), LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     CALL SGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
+     $                           LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
+     $                           1 )
+                     CALL SGEMV( '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 SLASET( '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 SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+                     CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+                     K = K + MB
+                     II = II + MB
+  160             CONTINUE
+*
+*
+*                 Solve Z' * x = RHS
+*
+                  CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 170 K = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( 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 SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+                     CALL SCOPY( 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 SGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+     $                           C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
+     $                           F( IS, 1 ), LDF )
+                     CALL SGEMM( '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 SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+     $                           A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
+     $                           ONE, C( IE+1, JS ), LDC )
+                     CALL SGEMM( '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 STGSY2
+*
+      END
diff --git a/SRC/stgsyl.f b/SRC/stgsyl.f
new file mode 100644
index 00000000..10d35951
--- /dev/null
+++ b/SRC/stgsyl.f
@@ -0,0 +1,556 @@
+      SUBROUTINE STGSYL( 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
+      REAL               DIF, SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STGSYL 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', STGSYL 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 SLACON.
+*
+*  If IJOB >= 1, STGSYL 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.
+*               ( SGECON 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL
+*          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) REAL
+*          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) REAL 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 SCOPY by calls to SLASET.
+*  Sven Hammarling, 1/5/02.
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+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
+      REAL               DSCALE, DSUM, SCALE2, SCALOC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SGEMM, SLACPY, SLASET, SSCAL, STGSY2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, REAL, 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( 'STGSYL', -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, 'STGSYL', TRANS, M, N, -1, -1 )
+      NB = ILAENV( 5, 'STGSYL', TRANS, M, N, -1, -1 )
+*
+      ISOLVE = 1
+      IFUNC = 0
+      IF( NOTRAN ) THEN
+         IF( IJOB.GE.3 ) THEN
+            IFUNC = IJOB - 2
+            CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+            CALL SLASET( 'F', M, N, ZERO, ZERO, 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
+*
+         DO 30 IROUND = 1, ISOLVE
+*
+*           Use unblocked Level 2 solver
+*
+            DSCALE = ZERO
+            DSUM = ONE
+            PQ = 0
+            CALL STGSY2( 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( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( REAL( 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 SLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+               CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL SLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL SLACPY( '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 STGSY2( 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 SSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+   80                CONTINUE
+                     DO 90 K = JS, JE
+                        CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+   90                CONTINUE
+                     DO 100 K = JS, JE
+                        CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+                        CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+  100                CONTINUE
+                     DO 110 K = JE + 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL SSCAL( 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 SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           A( 1, IS ), LDA, C( IS, JS ), LDC, ONE,
+     $                           C( 1, JS ), LDC )
+                     CALL SGEMM( '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 SGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+     $                           F( IS, JS ), LDF, B( JS, JE+1 ), LDB,
+     $                           ONE, C( IS, JE+1 ), LDC )
+                     CALL SGEMM( '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( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( REAL( 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 SLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+               CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL SLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL SLACPY( '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 STGSY2( 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 SSCAL( M, SCALOC, C( 1, K ), 1 )
+                     CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+  160             CONTINUE
+                  DO 170 K = JS, JE
+                     CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+                     CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+  170             CONTINUE
+                  DO 180 K = JS, JE
+                     CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+                     CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+  180             CONTINUE
+                  DO 190 K = JE + 1, N
+                     CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+                     CALL SSCAL( 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 SGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ),
+     $                        LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ),
+     $                        LDF )
+                  CALL SGEMM( '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 SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+     $                        A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE,
+     $                        C( IE+1, JS ), LDC )
+                  CALL SGEMM( '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 STGSYL
+*
+      END
diff --git a/SRC/stpcon.f b/SRC/stpcon.f
new file mode 100644
index 00000000..46eb8b61
--- /dev/null
+++ b/SRC/stpcon.f
@@ -0,0 +1,191 @@
+      SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, N
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STPCON estimates the reciprocal of the condition number of a packed
+*  triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  RCOND   (output) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLANTP
+      EXTERNAL           LSAME, ISAMAX, SLAMCH, SLANTP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATPS, SRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, REAL
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the norm of the inverse of A.
+*
+         AINVNM = ZERO
+         NORMIN = 'N'
+         IF( ONENRM ) THEN
+            KASE1 = 1
+         ELSE
+            KASE1 = 2
+         END IF
+         KASE = 0
+   10    CONTINUE
+         CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL SLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
+     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL SLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP,
+     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = ISAMAX( N, WORK, 1 )
+               XNORM = ABS( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL SRSCL( 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 STPCON
+*
+      END
diff --git a/SRC/stprfs.f b/SRC/stprfs.f
new file mode 100644
index 00000000..7d008825
--- /dev/null
+++ b/SRC/stprfs.f
@@ -0,0 +1,379 @@
+      SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STPRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular packed
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by STPTRS or some other
+*  means before entering this routine.  STPRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  B       (input) REAL 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) REAL array, dimension (LDX,NRHS)
+*          The solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANST
+      INTEGER            I, J, K, KASE, KC, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, STPMV, STPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STPRFS', -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 = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A or A', depending on TRANS.
+*
+         CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL STPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+         CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 30 I = 1, K
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+   30                CONTINUE
+                     KC = KC + K
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+   50                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+                     KC = KC + K
+   60             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 70 I = K, N
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+   70                CONTINUE
+                     KC = KC + N - K + 1
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+   90                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+                     KC = KC + N - K + 1
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A')*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+  110                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + K
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+  130                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + K
+  140             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+  150                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + N - K + 1
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+  170                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+                     KC = KC + N - K + 1
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL SLACN2( 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)').
+*
+               CALL STPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
+               DO 220 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  230          CONTINUE
+               CALL STPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of STPRFS
+*
+      END
diff --git a/SRC/stptri.f b/SRC/stptri.f
new file mode 100644
index 00000000..4d30c74f
--- /dev/null
+++ b/SRC/stptri.f
@@ -0,0 +1,175 @@
+      SUBROUTINE STPTRI( UPLO, DIAG, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STPTRI computes the inverse of a real upper or lower triangular
+*  matrix A stored in packed format.
+*
+*  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.
+*
+*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangular matrix A, stored
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same packed storage format.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  A triangular matrix A can be transferred to packed storage using one
+*  of the following program segments:
+*
+*  UPLO = 'U':                      UPLO = 'L':
+*
+*        JC = 1                           JC = 1
+*        DO 2 J = 1, N                    DO 2 J = 1, N
+*           DO 1 I = 1, J                    DO 1 I = J, N
+*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
+*      1    CONTINUE                    1    CONTINUE
+*           JC = JC + J                      JC = JC + N - J + 1
+*      2 CONTINUE                       2 CONTINUE
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC, JCLAST, JJ
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, STPMV, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Check for singularity if non-unit.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JJ = 0
+            DO 10 INFO = 1, N
+               JJ = JJ + INFO
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            JJ = 1
+            DO 20 INFO = 1, N
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+               JJ = JJ + N - INFO + 1
+   20       CONTINUE
+         END IF
+         INFO = 0
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Compute inverse of upper triangular matrix.
+*
+         JC = 1
+         DO 30 J = 1, N
+            IF( NOUNIT ) THEN
+               AP( JC+J-1 ) = ONE / AP( JC+J-1 )
+               AJJ = -AP( JC+J-1 )
+            ELSE
+               AJJ = -ONE
+            END IF
+*
+*           Compute elements 1:j-1 of j-th column.
+*
+            CALL STPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
+     $                  AP( JC ), 1 )
+            CALL SSCAL( J-1, AJJ, AP( JC ), 1 )
+            JC = JC + J
+   30    CONTINUE
+*
+      ELSE
+*
+*        Compute inverse of lower triangular matrix.
+*
+         JC = N*( N+1 ) / 2
+         DO 40 J = N, 1, -1
+            IF( NOUNIT ) THEN
+               AP( JC ) = ONE / AP( JC )
+               AJJ = -AP( JC )
+            ELSE
+               AJJ = -ONE
+            END IF
+            IF( J.LT.N ) THEN
+*
+*              Compute elements j+1:n of j-th column.
+*
+               CALL STPMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     AP( JCLAST ), AP( JC+1 ), 1 )
+               CALL SSCAL( N-J, AJJ, AP( JC+1 ), 1 )
+            END IF
+            JCLAST = JC
+            JC = JC - N + J - 2
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of STPTRI
+*
+      END
diff --git a/SRC/stptrs.f b/SRC/stptrs.f
new file mode 100644
index 00000000..201f83f1
--- /dev/null
+++ b/SRC/stptrs.f
@@ -0,0 +1,153 @@
+      SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      REAL               AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STPTRS solves a triangular system of the form
+*
+*     A * X = B  or  A**T * X = B,
+*
+*  where A is a triangular matrix of order N stored in packed format,
+*  and B is an N-by-NRHS matrix.  A check is made to verify that A is
+*  nonsingular.
+*
+*  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.
+*
+*  AP      (input) REAL array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  B       (input/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STPTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JC = 1
+            DO 10 INFO = 1, N
+               IF( AP( JC+INFO-1 ).EQ.ZERO )
+     $            RETURN
+               JC = JC + INFO
+   10       CONTINUE
+         ELSE
+            JC = 1
+            DO 20 INFO = 1, N
+               IF( AP( JC ).EQ.ZERO )
+     $            RETURN
+               JC = JC + N - INFO + 1
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve A * x = b  or  A' * x = b.
+*
+      DO 30 J = 1, NRHS
+         CALL STPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of STPTRS
+*
+      END
diff --git a/SRC/strcon.f b/SRC/strcon.f
new file mode 100644
index 00000000..c2b088b5
--- /dev/null
+++ b/SRC/strcon.f
@@ -0,0 +1,197 @@
+      SUBROUTINE STRCON( 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, LDA, N
+      REAL               RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRCON 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) REAL 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) REAL
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      REAL               AINVNM, ANORM, SCALE, SMLNUM, XNORM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SLAMCH, SLANTR
+      EXTERNAL           LSAME, ISAMAX, SLAMCH, SLANTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLATRS, SRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, REAL
+*     ..
+*     .. 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( 'STRCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = SLANTR( 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 SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL SLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
+     $                      LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL SLATRS( 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 = ISAMAX( N, WORK, 1 )
+               XNORM = ABS( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL SRSCL( 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 STRCON
+*
+      END
diff --git a/SRC/strevc.f b/SRC/strevc.f
new file mode 100644
index 00000000..77e73cc5
--- /dev/null
+++ b/SRC/strevc.f
@@ -0,0 +1,981 @@
+      SUBROUTINE STREVC( 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( * )
+      REAL               T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STREVC 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 SHSEQR.
+*  
+*  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) REAL 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) REAL 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 SHSEQR).
+*          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) REAL 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 SHSEQR).
+*          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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
+      INTEGER            I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
+      REAL               BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
+     $                   SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
+     $                   XNORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ISAMAX
+      REAL               SDOT, SLAMCH
+      EXTERNAL           LSAME, ISAMAX, SDOT, SLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Local Arrays ..
+      REAL               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( 'STREVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set the constants to control overflow.
+*
+      UNFL = SLAMCH( 'Safe minimum' )
+      OVFL = ONE / UNFL
+      CALL SLABAD( UNFL, OVFL )
+      ULP = SLAMCH( '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 SLALN2( .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 SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                     WORK( J+N ) = X( 1, 1 )
+*
+*                    Update right-hand side
+*
+                     CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+*
+                  ELSE
+*
+*                    2-by-2 diagonal block
+*
+                     CALL SLALN2( .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 SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                     WORK( J-1+N ) = X( 1, 1 )
+                     WORK( J+N ) = X( 2, 1 )
+*
+*                    Update right-hand side
+*
+                     CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL SAXPY( 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 SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
+*
+                  II = ISAMAX( KI, VR( 1, IS ), 1 )
+                  REMAX = ONE / ABS( VR( II, IS ) )
+                  CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+                  DO 70 K = KI + 1, N
+                     VR( K, IS ) = ZERO
+   70             CONTINUE
+               ELSE
+                  IF( KI.GT.1 )
+     $               CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR,
+     $                           WORK( 1+N ), 1, WORK( KI+N ),
+     $                           VR( 1, KI ), 1 )
+*
+                  II = ISAMAX( N, VR( 1, KI ), 1 )
+                  REMAX = ONE / ABS( VR( II, KI ) )
+                  CALL SSCAL( 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 SLALN2( .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 SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                        CALL SSCAL( 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 SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
+     $                           WORK( 1+N2 ), 1 )
+*
+                  ELSE
+*
+*                    2-by-2 diagonal block
+*
+                     CALL SLALN2( .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 SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                        CALL SSCAL( 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 SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
+     $                           WORK( 1+N2 ), 1 )
+                     CALL SAXPY( 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 SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
+                  CALL SCOPY( 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 SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
+                  CALL SSCAL( 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 SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+     $                           WORK( 1+N ), 1, WORK( KI-1+N ),
+     $                           VR( 1, KI-1 ), 1 )
+                     CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+     $                           WORK( 1+N2 ), 1, WORK( KI+N2 ),
+     $                           VR( 1, KI ), 1 )
+                  ELSE
+                     CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
+                     CALL SSCAL( 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 SSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
+                  CALL SSCAL( 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 SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             SDOT( J-KI-1, T( KI+1, J ), 1,
+     $                             WORK( KI+1+N ), 1 )
+*
+*                    Solve (T(J,J)-WR)'*X = WORK
+*
+                     CALL SLALN2( .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 SSCAL( 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 SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             SDOT( J-KI-1, T( KI+1, J ), 1,
+     $                             WORK( KI+1+N ), 1 )
+*
+                     WORK( J+1+N ) = WORK( J+1+N ) -
+     $                               SDOT( 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 SLALN2( .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 SSCAL( 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 SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+*
+                  II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
+                  REMAX = ONE / ABS( VL( II, IS ) )
+                  CALL SSCAL( 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 SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
+     $                           WORK( KI+1+N ), 1, WORK( KI+N ),
+     $                           VL( 1, KI ), 1 )
+*
+                  II = ISAMAX( N, VL( 1, KI ), 1 )
+                  REMAX = ONE / ABS( VL( II, KI ) )
+                  CALL SSCAL( 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 SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             SDOT( J-KI-2, T( KI+2, J ), 1,
+     $                             WORK( KI+2+N ), 1 )
+                     WORK( J+N2 ) = WORK( J+N2 ) -
+     $                              SDOT( 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 SLALN2( .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 SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+                        CALL SSCAL( 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 SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             SDOT( J-KI-2, T( KI+2, J ), 1,
+     $                             WORK( KI+2+N ), 1 )
+*
+                     WORK( J+N2 ) = WORK( J+N2 ) -
+     $                              SDOT( J-KI-2, T( KI+2, J ), 1,
+     $                              WORK( KI+2+N2 ), 1 )
+*
+                     WORK( J+1+N ) = WORK( J+1+N ) -
+     $                               SDOT( J-KI-2, T( KI+2, J+1 ), 1,
+     $                               WORK( KI+2+N ), 1 )
+*
+                     WORK( J+1+N2 ) = WORK( J+1+N2 ) -
+     $                                SDOT( 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 SLALN2( .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 SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+                        CALL SSCAL( 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 SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+                  CALL SCOPY( 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 SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+                  CALL SSCAL( 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 SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+     $                           LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
+     $                           VL( 1, KI ), 1 )
+                     CALL SGEMV( '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 SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
+                     CALL SSCAL( 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 SSCAL( N, REMAX, VL( 1, KI ), 1 )
+                  CALL SSCAL( 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 STREVC
+*
+      END
diff --git a/SRC/strexc.f b/SRC/strexc.f
new file mode 100644
index 00000000..7db8820d
--- /dev/null
+++ b/SRC/strexc.f
@@ -0,0 +1,345 @@
+      SUBROUTINE STREXC( 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 ..
+      REAL               Q( LDQ, * ), T( LDT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STREXC 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 SHSEQR), 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) REAL array, dimension (LDT,N)
+*          On entry, the upper quasi-triangular matrix T, in Schur
+*          Schur canonical form.
+*          On exit, the reordered upper quasi-triangular matrix, again
+*          in Schur canonical form.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) REAL 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) REAL array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          = 1:  two adjacent blocks were too close to swap (the problem
+*                is very ill-conditioned); T may have been partially
+*                reordered, and ILST points to the first row of the
+*                current position of the block being moved.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTQ
+      INTEGER            HERE, NBF, NBL, NBNEXT
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAEXC, 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( 'STREXC', -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 SLAEXC( 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 SLAEXC( 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 SLAEXC( 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 SLAEXC( 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 SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+     $                         WORK, INFO )
+                  CALL SLAEXC( 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 SLAEXC( 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 SLAEXC( 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 SLAEXC( 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 SLAEXC( 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 SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+     $                         WORK, INFO )
+                  CALL SLAEXC( 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 STREXC
+*
+      END
diff --git a/SRC/strrfs.f b/SRC/strrfs.f
new file mode 100644
index 00000000..1cb4d67d
--- /dev/null
+++ b/SRC/strrfs.f
@@ -0,0 +1,375 @@
+      SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, 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 SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDA, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      REAL               A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by STRTRS or some other
+*  means before entering this routine.  STRRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) REAL 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) REAL 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) REAL array, dimension (LDX,NRHS)
+*          The solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) REAL 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) REAL 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) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANST
+      INTEGER            I, J, K, KASE, NZ
+      REAL               EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SLACN2, STRMV, STRSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLAMCH
+      EXTERNAL           LSAME, SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STRRFS', -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 = SLAMCH( 'Epsilon' )
+      SAFMIN = SLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A or A', depending on TRANS.
+*
+         CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL STRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
+         CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 30 I = 1, K
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   50                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 70 I = K, N
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = ABS( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   90                CONTINUE
+                     WORK( K ) = WORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A')*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  110                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  130                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  150                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = ABS( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+  170                CONTINUE
+                     WORK( K ) = WORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use SLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL SLACN2( 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)').
+*
+               CALL STRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ),
+     $                     1 )
+               DO 220 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  230          CONTINUE
+               CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ),
+     $                     1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of STRRFS
+*
+      END
diff --git a/SRC/strsen.f b/SRC/strsen.f
new file mode 100644
index 00000000..249220a2
--- /dev/null
+++ b/SRC/strsen.f
@@ -0,0 +1,461 @@
+      SUBROUTINE STRSEN( 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
+*
+*     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, JOB
+      INTEGER            INFO, LDQ, LDT, LIWORK, LWORK, M, N
+      REAL               S, SEP
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      REAL               Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
+     $                   WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRSEN 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 SHSEQR), 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) REAL 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) REAL 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) REAL array, dimension (N)
+*  WI      (output) REAL 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) REAL
+*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+*          condition number for the selected cluster of eigenvalues.
+*          S cannot underestimate the true reciprocal condition number
+*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+*          If JOB = 'N' or 'V', S is not referenced.
+*
+*  SEP     (output) REAL
+*          If JOB = 'V' or 'B', SEP is the estimated reciprocal
+*          condition number of the specified invariant subspace. If
+*          M = 0 or N, SEP = norm(T).
+*          If JOB = 'N' or 'E', SEP is not referenced.
+*
+*  WORK    (workspace/output) REAL 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
+*  ===============
+*
+*  STRSEN 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
+     $                    WANTSP
+      INTEGER            IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
+     $                   NN
+      REAL               EST, RNORM, SCALE
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SLANGE
+      EXTERNAL           LSAME, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLACN2, SLACPY, STREXC, STRSYL, 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( 'STRSEN', -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 = SLANGE( '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 STREXC( 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 SLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
+         CALL STRSYL( '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 = SLANGE( '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 SLACN2( 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 STRSYL( '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 STRSYL( '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 STRSEN
+*
+      END
diff --git a/SRC/strsna.f b/SRC/strsna.f
new file mode 100644
index 00000000..ddfa0e3f
--- /dev/null
+++ b/SRC/strsna.f
@@ -0,0 +1,495 @@
+      SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, JOB
+      INTEGER            INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      REAL               S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or right eigenvectors of a real upper
+*  quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
+*  orthogonal).
+*
+*  T must be in Schur canonical form (as returned by SHSEQR), 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
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (SEP):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (SEP);
+*          = 'B': for both eigenvalues and eigenvectors (S and SEP).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the eigenpair corresponding to a real eigenvalue w(j),
+*          SELECT(j) must be set to .TRUE.. To select condition numbers
+*          corresponding to a complex conjugate pair of eigenvalues w(j)
+*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+*          set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input) REAL 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) REAL array, dimension (LDVL,M)
+*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
+*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VL, as returned by
+*          SHSEIN or STREVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) REAL array, dimension (LDVR,M)
+*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
+*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VR, as returned by
+*          SHSEIN or STREVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) REAL array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array. For a complex conjugate pair of eigenvalues two
+*          consecutive elements of S are set to the same value. Thus
+*          S(j), SEP(j), and the j-th columns of VL and VR all
+*          correspond to the same eigenpair (but not in general the
+*          j-th eigenpair, unless all eigenpairs are selected).
+*          If JOB = 'V', S is not referenced.
+*
+*  SEP     (output) REAL array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array. For a complex eigenvector two
+*          consecutive elements of SEP are set to the same value. If
+*          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
+*          is set to 0; this can only occur when the true value would be
+*          very small anyway.
+*          If JOB = 'E', SEP is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S (if JOB = 'E' or 'B')
+*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and/or SEP actually
+*          used to store the estimated condition numbers.
+*          If HOWMNY = 'A', M is set to N.
+*
+*  WORK    (workspace) REAL array, dimension (LDWORK,N+6)
+*          If JOB = 'E', WORK is not referenced.
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
+*
+*  IWORK   (workspace) INTEGER array, dimension (2*(N-1))
+*          If JOB = 'E', IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of an eigenvalue lambda is
+*  defined as
+*
+*          S(lambda) = |v'*u| / (norm(u)*norm(v))
+*
+*  where u and v are the right and left eigenvectors of T corresponding
+*  to lambda; v' denotes the conjugate-transpose of v, and norm(u)
+*  denotes the Euclidean norm. These reciprocal condition numbers always
+*  lie between zero (very badly conditioned) and one (very well
+*  conditioned). If n = 1, S(lambda) is defined to be 1.
+*
+*  An approximate error bound for a computed eigenvalue W(i) is given by
+*
+*                      EPS * norm(T) / S(i)
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number of the right eigenvector u
+*  corresponding to lambda is defined as follows. Suppose
+*
+*              T = ( lambda  c  )
+*                  (   0    T22 )
+*
+*  Then the reciprocal condition number is
+*
+*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
+*
+*  where sigma-min denotes the smallest singular value. We approximate
+*  the smallest singular value by the reciprocal of an estimate of the
+*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
+*  defined to be abs(T(1,1)).
+*
+*  An approximate error bound for a computed right eigenvector VR(i)
+*  is given by
+*
+*                      EPS * norm(T) / SEP(i)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            PAIR, SOMCON, WANTBH, WANTS, WANTSP
+      INTEGER            I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
+      REAL               BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
+     $                   MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+      REAL               DUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT, SLAMCH, SLAPY2, SNRM2
+      EXTERNAL           LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLABAD, SLACN2, SLACPY, SLAQTR, STREXC, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      ELSE
+*
+*        Set M to the number of eigenpairs for which condition numbers
+*        are required, and test MM.
+*
+         IF( SOMCON ) THEN
+            M = 0
+            PAIR = .FALSE.
+            DO 10 K = 1, N
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+               ELSE
+                  IF( K.LT.N ) THEN
+                     IF( T( K+1, K ).EQ.ZERO ) THEN
+                        IF( SELECT( K ) )
+     $                     M = M + 1
+                     ELSE
+                        PAIR = .TRUE.
+                        IF( SELECT( K ) .OR. SELECT( K+1 ) )
+     $                     M = M + 2
+                     END IF
+                  ELSE
+                     IF( SELECT( N ) )
+     $                  M = M + 1
+                  END IF
+               END IF
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( MM.LT.M ) THEN
+            INFO = -13
+         ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'STRSNA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( 1 ) )
+     $         RETURN
+         END IF
+         IF( WANTS )
+     $      S( 1 ) = ONE
+         IF( WANTSP )
+     $      SEP( 1 ) = ABS( T( 1, 1 ) )
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+*
+      KS = 0
+      PAIR = .FALSE.
+      DO 60 K = 1, N
+*
+*        Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+            GO TO 60
+         ELSE
+            IF( K.LT.N )
+     $         PAIR = T( K+1, K ).NE.ZERO
+         END IF
+*
+*        Determine whether condition numbers are required for the k-th
+*        eigenpair.
+*
+         IF( SOMCON ) THEN
+            IF( PAIR ) THEN
+               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+     $            GO TO 60
+            ELSE
+               IF( .NOT.SELECT( K ) )
+     $            GO TO 60
+            END IF
+         END IF
+*
+         KS = KS + 1
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            IF( .NOT.PAIR ) THEN
+*
+*              Real eigenvalue.
+*
+               PROD = SDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+               RNRM = SNRM2( N, VR( 1, KS ), 1 )
+               LNRM = SNRM2( N, VL( 1, KS ), 1 )
+               S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
+            ELSE
+*
+*              Complex eigenvalue.
+*
+               PROD1 = SDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+               PROD1 = PROD1 + SDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
+     $                 1 )
+               PROD2 = SDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
+               PROD2 = PROD2 - SDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
+     $                 1 )
+               RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
+     $                SNRM2( N, VR( 1, KS+1 ), 1 ) )
+               LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
+     $                SNRM2( N, VL( 1, KS+1 ), 1 ) )
+               COND = SLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
+               S( KS ) = COND
+               S( KS+1 ) = COND
+            END IF
+         END IF
+*
+         IF( WANTSP ) THEN
+*
+*           Estimate the reciprocal condition number of the k-th
+*           eigenvector.
+*
+*           Copy the matrix T to the array WORK and swap the diagonal
+*           block beginning at T(k,k) to the (1,1) position.
+*
+            CALL SLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
+            IFST = K
+            ILST = 1
+            CALL STREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
+     $                   WORK( 1, N+1 ), IERR )
+*
+            IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+*              Could not swap because blocks not well separated
+*
+               SCALE = ONE
+               EST = BIGNUM
+            ELSE
+*
+*              Reordering successful
+*
+               IF( WORK( 2, 1 ).EQ.ZERO ) THEN
+*
+*                 Form C = T22 - lambda*I in WORK(2:N,2:N).
+*
+                  DO 20 I = 2, N
+                     WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
+   20             CONTINUE
+                  N2 = 1
+                  NN = N - 1
+               ELSE
+*
+*                 Triangularize the 2 by 2 block by unitary
+*                 transformation U = [  cs   i*ss ]
+*                                    [ i*ss   cs  ].
+*                 such that the (1,1) position of WORK is complex
+*                 eigenvalue lambda with positive imaginary part. (2,2)
+*                 position of WORK is the complex eigenvalue lambda
+*                 with negative imaginary  part.
+*
+                  MU = SQRT( ABS( WORK( 1, 2 ) ) )*
+     $                 SQRT( ABS( WORK( 2, 1 ) ) )
+                  DELTA = SLAPY2( MU, WORK( 2, 1 ) )
+                  CS = MU / DELTA
+                  SN = -WORK( 2, 1 ) / DELTA
+*
+*                 Form
+*
+*                 C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
+*                                        [   mu                     ]
+*                                        [         ..               ]
+*                                        [             ..           ]
+*                                        [                  mu      ]
+*                 where C' is conjugate transpose of complex matrix C,
+*                 and RWORK is stored starting in the N+1-st column of
+*                 WORK.
+*
+                  DO 30 J = 3, N
+                     WORK( 2, J ) = CS*WORK( 2, J )
+                     WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
+   30             CONTINUE
+                  WORK( 2, 2 ) = ZERO
+*
+                  WORK( 1, N+1 ) = TWO*MU
+                  DO 40 I = 2, N - 1
+                     WORK( I, N+1 ) = SN*WORK( 1, I+1 )
+   40             CONTINUE
+                  N2 = 2
+                  NN = 2*( N-1 )
+               END IF
+*
+*              Estimate norm(inv(C'))
+*
+               EST = ZERO
+               KASE = 0
+   50          CONTINUE
+               CALL SLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
+     $                      EST, KASE, ISAVE )
+               IF( KASE.NE.0 ) THEN
+                  IF( KASE.EQ.1 ) THEN
+                     IF( N2.EQ.1 ) THEN
+*
+*                       Real eigenvalue: solve C'*x = scale*c.
+*
+                        CALL SLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
+     $                               LDWORK, DUMMY, DUMM, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+                     ELSE
+*
+*                       Complex eigenvalue: solve
+*                       C'*(p+iq) = scale*(c+id) in real arithmetic.
+*
+                        CALL SLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
+     $                               LDWORK, WORK( 1, N+1 ), MU, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+                     END IF
+                  ELSE
+                     IF( N2.EQ.1 ) THEN
+*
+*                       Real eigenvalue: solve C*x = scale*c.
+*
+                        CALL SLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
+     $                               LDWORK, DUMMY, DUMM, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+                     ELSE
+*
+*                       Complex eigenvalue: solve
+*                       C*(p+iq) = scale*(c+id) in real arithmetic.
+*
+                        CALL SLAQTR( .FALSE., .FALSE., N-1,
+     $                               WORK( 2, 2 ), LDWORK,
+     $                               WORK( 1, N+1 ), MU, SCALE,
+     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
+     $                               IERR )
+*
+                     END IF
+                  END IF
+*
+                  GO TO 50
+               END IF
+            END IF
+*
+            SEP( KS ) = SCALE / MAX( EST, SMLNUM )
+            IF( PAIR )
+     $         SEP( KS+1 ) = SEP( KS )
+         END IF
+*
+         IF( PAIR )
+     $      KS = KS + 1
+*
+   60 CONTINUE
+      RETURN
+*
+*     End of STRSNA
+*
+      END
diff --git a/SRC/strsyl.f b/SRC/strsyl.f
new file mode 100644
index 00000000..e9c5ee79
--- /dev/null
+++ b/SRC/strsyl.f
@@ -0,0 +1,913 @@
+      SUBROUTINE STRSYL( 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
+      REAL               SCALE
+*     ..
+*     .. Array Arguments ..
+      REAL               A( LDA, * ), B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRSYL 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 SHSEQR), 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) REAL 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) REAL 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) REAL 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) REAL
+*          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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRNA, NOTRNB
+      INTEGER            IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
+      REAL               A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
+     $                   SMLNUM, SUML, SUMR, XNORM
+*     ..
+*     .. Local Arrays ..
+      REAL               DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      REAL               SDOT, SLAMCH, SLANGE
+      EXTERNAL           LSAME, SDOT, SLAMCH, SLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLABAD, SLALN2, SLASY2, SSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, REAL
+*     ..
+*     .. 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( 'STRSYL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = SLAMCH( 'P' )
+      SMLNUM = SLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL SLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM*REAL( M*N ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+      SMIN = MAX( SMLNUM, EPS*SLANGE( 'M', M, M, A, LDA, DUM ),
+     $       EPS*SLANGE( '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 70 L = 1, N
+            IF( L.LT.LNEXT )
+     $         GO TO 70
+            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 60 K = M, 1, -1
+               IF( K.GT.KNEXT )
+     $            GO TO 60
+               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 = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                         C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 SSCAL( 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 = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  CALL SLALN2( .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 SSCAL( 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 = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                         C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+                  SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                         C( MIN( K1+1, M ), L2 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+                  CALL SLALN2( .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 40 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+   40                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 = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+                  CALL SLASY2( .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 50 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+   50                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
+*
+   60       CONTINUE
+*
+   70    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 130 L = 1, N
+            IF( L.LT.LNEXT )
+     $         GO TO 130
+            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 120 K = 1, M
+               IF( K.LT.KNEXT )
+     $            GO TO 120
+               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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 80 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+   80                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  CALL SLALN2( .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 90 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+   90                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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+                  SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+                  CALL SLALN2( .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 100 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  100                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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+                  SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+                  CALL SLASY2( .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 110 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  110                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
+*
+  120       CONTINUE
+  130    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 190 L = N, 1, -1
+            IF( L.GT.LNEXT )
+     $         GO TO 190
+            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 180 K = 1, M
+               IF( K.LT.KNEXT )
+     $            GO TO 180
+               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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 140 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  140                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 SLALN2( .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 150 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  150                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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = SDOT( 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 SLALN2( .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 160 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  160                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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+                  SUMR = SDOT( 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 SLASY2( .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 170 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  170                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
+*
+  180       CONTINUE
+  190    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 250 L = N, 1, -1
+            IF( L.GT.LNEXT )
+     $         GO TO 250
+            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 240 K = M, 1, -1
+               IF( K.GT.KNEXT )
+     $            GO TO 240
+               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 = SDOT( M-K1, A( K1, MIN(K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 200 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  200                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 SLALN2( .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 210 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  210                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 = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                         C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                         C( MIN( K1+1, M ), L2 ), 1 )
+                  SUMR = SDOT( 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 SLALN2( .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 220 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  220                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 = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = SDOT( 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 = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                         C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = SDOT( 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 SLASY2( .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 230 J = 1, N
+                        CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+  230                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
+*
+  240       CONTINUE
+  250    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of STRSYL
+*
+      END
diff --git a/SRC/strti2.f b/SRC/strti2.f
new file mode 100644
index 00000000..79ca5c8b
--- /dev/null
+++ b/SRC/strti2.f
@@ -0,0 +1,146 @@
+      SUBROUTINE STRTI2( 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 ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRTI2 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) REAL 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 ..
+      REAL               ONE
+      PARAMETER          ( ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+      REAL               AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SSCAL, STRMV, 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( 'STRTI2', -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 STRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
+     $                  A( 1, J ), 1 )
+            CALL SSCAL( 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 STRMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
+               CALL SSCAL( N-J, AJJ, A( J+1, J ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of STRTI2
+*
+      END
diff --git a/SRC/strtri.f b/SRC/strtri.f
new file mode 100644
index 00000000..3bda8ac3
--- /dev/null
+++ b/SRC/strtri.f
@@ -0,0 +1,176 @@
+      SUBROUTINE STRTRI( 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 ..
+      REAL               A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRTRI 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JB, NB, NN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STRMM, STRSM, STRTI2, 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( 'STRTRI', -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, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL STRTI2( 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 STRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
+               CALL STRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
+*
+*              Compute inverse of current diagonal block
+*
+               CALL STRTI2( '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 STRMM( 'Left', 'Lower', 'No transpose', DIAG,
+     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
+     $                        A( J+JB, J ), LDA )
+                  CALL STRSM( '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 STRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
+   30       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of STRTRI
+*
+      END
diff --git a/SRC/strtrs.f b/SRC/strtrs.f
new file mode 100644
index 00000000..df36982d
--- /dev/null
+++ b/SRC/strtrs.f
@@ -0,0 +1,147 @@
+      SUBROUTINE STRTRS( 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 ..
+      REAL               A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STRTRS 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) REAL 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) REAL 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 ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           STRSM, 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( 'STRTRS', -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 STRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+     $            LDB )
+*
+      RETURN
+*
+*     End of STRTRS
+*
+      END
diff --git a/SRC/stzrqf.f b/SRC/stzrqf.f
new file mode 100644
index 00000000..d1a54558
--- /dev/null
+++ b/SRC/stzrqf.f
@@ -0,0 +1,164 @@
+      SUBROUTINE STZRQF( 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 ..
+      REAL               A( LDA, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine STZRZF.
+*
+*  STZRQF 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) REAL 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) REAL 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 ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K, M1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SAXPY, SCOPY, SGEMV, SGER, SLARFP, 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( 'STZRQF', -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 SLARFP( 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 SCOPY( K-1, A( 1, K ), 1, TAU, 1 )
+*
+*              Form   w = a( k ) + B*z( k )  in TAU.
+*
+               CALL SGEMV( '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 SAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
+               CALL SGER( 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 STZRQF
+*
+      END
diff --git a/SRC/stzrzf.f b/SRC/stzrzf.f
new file mode 100644
index 00000000..33459c5c
--- /dev/null
+++ b/SRC/stzrzf.f
@@ -0,0 +1,244 @@
+      SUBROUTINE STZRZF( 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 ..
+      REAL               A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  STZRZF 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) REAL 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) REAL array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) REAL 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 ..
+      REAL               ZERO
+      PARAMETER          ( ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLARZB, SLARZT, SLATRZ, 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, 'SGERQF', ' ', 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( 'STZRZF', -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, 'SGERQF', ' ', 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, 'SGERQF', ' ', 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 SLATRZ( 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 SLARZT( '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 SLARZB( '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 SLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of STZRZF
+*
+      END
diff --git a/SRC/xerbla.f b/SRC/xerbla.f
new file mode 100644
index 00000000..99ca6aa8
--- /dev/null
+++ b/SRC/xerbla.f
@@ -0,0 +1,49 @@
+      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*(*)       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*(*)
+*          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.
+*
+* =====================================================================
+*
+*     .. External Functions ..
+      INTEGER ILA_LEN_TRIM
+      EXTERNAL ILA_LEN_TRIM
+*     ..
+*     .. Executable Statements ..
+*
+      WRITE( *, FMT = 9999 )SRNAME(1:ILA_LEN_TRIM(SRNAME)), INFO
+*
+      STOP
+*
+ 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
+     $      'an illegal value' )
+*
+*     End of XERBLA
+*
+      END
diff --git a/SRC/xerbla_array.f b/SRC/xerbla_array.f
new file mode 100644
index 00000000..30a91362
--- /dev/null
+++ b/SRC/xerbla_array.f
@@ -0,0 +1,74 @@
+      SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO)
+!
+!  -- LAPACK auxiliary routine (version 3.1) --
+!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+!     September 19, 2006
+!
+      IMPLICIT NONE
+!     .. Scalar Arguments ..
+      INTEGER SRNAME_LEN, INFO
+!     ..
+!     .. Array Arguments ..
+      CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN)
+!     ..
+!
+!  Purpose
+!  =======
+!
+!  XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK
+!  and BLAS error handler.  Rather than taking a Fortran string argument
+!  as the function's name, XERBLA_ARRAY takes an array of single
+!  characters along with the array's length.  XERBLA_ARRAY then copies
+!  up to 32 characters of that array into a Fortran string and passes
+!  that to XERBLA.  If called with a non-positive SRNAME_LEN,
+!  XERBLA_ARRAY will call XERBLA with a string of all blank characters.
+!
+!  Say some macro or other device makes XERBLA_ARRAY available to C99
+!  by a name lapack_xerbla and with a common Fortran calling convention.
+!  Then a C99 program could invoke XERBLA via:
+!     {
+!       int flen = strlen(__func__);
+!       lapack_xerbla(__func__, &flen, &info);
+!     }
+!
+!  Providing XERBLA_ARRAY is not necessary for intercepting LAPACK
+!  errors.  XERBLA_ARRAY calls XERBLA.
+!
+!  Arguments
+!  =========
+!
+!  SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)
+!          The name of the routine which called XERBLA_ARRAY.
+!
+!  SRNAME_LEN (input) INTEGER
+!          The length of the name in SRNAME_ARRAY.
+!
+!  INFO    (input) INTEGER
+!          The position of the invalid parameter in the parameter list
+!          of the calling routine.
+!
+! =====================================================================
+!
+!     ..
+!     .. Local Scalars ..
+      INTEGER I
+!     ..
+!     .. Local Arrays ..
+      CHARACTER(32) SRNAME
+!     ..
+!     .. Intrinsic Functions ..
+      INTRINSIC MIN, LEN
+!     ..
+!     .. External Functions ..
+      EXTERNAL XERBLA
+!     ..
+!     .. Executable Statements ..
+      SRNAME = ''
+      DO I = 1, MIN(SRNAME_LEN, LEN(SRNAME))
+         SRNAME(I:I) = SRNAME_ARRAY(I)
+      END DO
+
+      CALL XERBLA(SRNAME, INFO)
+
+      RETURN
+      END
diff --git a/SRC/zbdsqr.f b/SRC/zbdsqr.f
new file mode 100644
index 00000000..f9086be5
--- /dev/null
+++ b/SRC/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/zcgesv.f b/SRC/zcgesv.f
new file mode 100644
index 00000000..5a6d5c28
--- /dev/null
+++ b/SRC/zcgesv.f
@@ -0,0 +1,345 @@
+      SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK,
+     +                   SWORK, ITER, INFO)
+*
+*  -- LAPACK PROTOTYPE driver routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     ..
+*     .. WARNING: PROTOTYPE ..
+*     This is an LAPACK PROTOTYPE routine which means that the
+*     interface of this routine is likely to be changed in the future
+*     based on community feedback.
+*
+*     ..
+*     .. Scalar Arguments ..
+      INTEGER INFO,ITER,LDA,LDB,LDX,N,NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER IPIV(*)
+      COMPLEX SWORK(*)
+      COMPLEX*16 A(LDA,*),B(LDB,*),WORK(N,*),X(LDX,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZCGESV 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.
+*
+*  ZCGESV first attempts to factorize the matrix in SINGLE COMPLEX PRECISION
+*  and use this factorization within an iterative refinement procedure to
+*  produce a solution with DOUBLE COMPLEX PRECISION normwise backward error
+*  quality (see below). If the approach fails the method switches to a
+*  DOUBLE COMPLEX PRECISION factorization and solve.
+*
+*  The iterative refinement is not going to be a winning strategy if
+*  the ratio SINGLE PRECISION performance over DOUBLE PRECISION performance
+*  is too small. A reasonable strategy should take the number of right-hand
+*  sides and the size of the matrix into account. This might be done with a 
+*  call to ILAENV in the future. Up to now, we always try iterative refinement.
+*
+*  The iterative refinement process is stopped if
+*      ITER > ITERMAX
+*  or for all the RHS we have:
+*      RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX 
+*  where
+*      o ITER is the number of the current iteration in the iterative
+*        refinement process
+*      o RNRM is the infinity-norm of the residual
+*      o XNRM is the infinity-norm of the solution
+*      o ANRM is the infinity-operator-norm of the matrix A
+*      o EPS is the machine epsilon returned by DLAMCH('Epsilon')
+*  The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively.
+*
+*  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 or input/ouptut) COMPLEX*16 array,
+*          dimension (LDA,N)
+*          On entry, the N-by-N coefficient matrix A.
+*          On exit, if iterative refinement has been successfully used
+*          (INFO.EQ.0 and ITER.GE.0, see description below), then A is
+*          unchanged, if double precision factorization has been used
+*          (INFO.EQ.0 and ITER.LT.0, see description below), then the
+*          array A contains the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  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).
+*          Corresponds either to the single precision factorization 
+*          (if INFO.EQ.0 and ITER.GE.0) or the double precision 
+*          factorization (if INFO.EQ.0 and ITER.LT.0).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS matrix of right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N*NRHS)
+*          This array is used to hold the residual vectors.
+*
+*  SWORK   (workspace) COMPLEX array, dimension (N*(N+NRHS))
+*          This array is used to use the single precision matrix and the 
+*          right-hand sides or solutions in single precision.
+*
+*  ITER    (output) INTEGER
+*          < 0: iterative refinement has failed, double precision
+*               factorization has been performed
+*               -1 : taking into account machine parameters, N, NRHS, it
+*                    is a priori not worth working in SINGLE PRECISION
+*               -2 : overflow of an entry when moving from double to
+*                    SINGLE PRECISION
+*               -3 : failure of SGETRF
+*               -31: stop the iterative refinement after the 30th
+*                    iterations
+*          > 0: iterative refinement has been sucessfully used.
+*               Returns the number of iterations
+*
+*  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) computed in DOUBLE PRECISION is
+*                exactly zero.  The factorization has been completed,
+*                but the factor U is exactly singular, so the solution
+*                could not be computed.
+*
+*  =========
+*
+*     .. Parameters ..
+      COMPLEX*16 NEGONE,ONE
+      PARAMETER (NEGONE=(-1.0D+00,0.0D+00),ONE=(1.0D+00,0.0D+00))
+*
+*     .. Local Scalars ..
+      LOGICAL DOITREF
+      INTEGER I,IITER,ITERMAX,OK,PTSA,PTSX
+      DOUBLE PRECISION ANRM,BWDMAX,CTE,EPS,RNRM,XNRM
+      COMPLEX*16 ZDUM
+*
+*     .. External Subroutines ..
+      EXTERNAL CGETRS,CGETRF,CLAG2Z,XERBLA,ZAXPY,
+     $         ZGEMM,ZLACPY,ZLAG2C
+*     ..
+*     .. External Functions ..
+      INTEGER IZAMAX
+      DOUBLE PRECISION DLAMCH,ZLANGE
+      EXTERNAL IZAMAX,DLAMCH,ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS,DBLE,MAX,SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      ITERMAX = 30
+      BWDMAX = 1.0E+00
+      DOITREF = .TRUE.
+*
+      OK = 0
+      INFO = 0
+      ITER = 0
+*
+*     Test the input parameters.
+*
+      IF (N.LT.0) THEN
+          INFO = -1
+      ELSE IF (NRHS.LT.0) THEN
+          INFO = -2
+      ELSE IF (LDA.LT.MAX(1,N)) THEN
+          INFO = -4
+      ELSE IF (LDB.LT.MAX(1,N)) THEN
+          INFO = -7
+      ELSE IF (LDX.LT.MAX(1,N)) THEN
+          INFO = -9
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('ZCGESV',-INFO)
+          RETURN
+      END IF
+*
+*     Quick return if (N.EQ.0).
+*
+      IF (N.EQ.0) RETURN
+*
+*     Skip single precision iterative refinement if a priori slower
+*     than double precision factorization.
+*
+      IF (.NOT.DOITREF) THEN
+          ITER = -1
+          GO TO 40
+      END IF
+*
+*     Compute some constants.
+*
+      ANRM = ZLANGE('I',N,N,A,LDA,WORK)
+      EPS = DLAMCH('Epsilon')
+      CTE = ANRM*EPS*SQRT(DBLE(N))*BWDMAX
+*
+*     Set the pointers PTSA, PTSX for referencing SA and SX in SWORK.
+*
+      PTSA = 1
+      PTSX = PTSA + N*N
+*
+*     Convert B from double precision to single precision and store the
+*     result in SX.
+*
+      CALL ZLAG2C(N,NRHS,B,LDB,SWORK(PTSX),N,INFO)
+*
+      IF (INFO.NE.0) THEN
+          ITER = -2
+          GO TO 40
+      END IF
+*
+*     Convert A from double precision to single precision and store the
+*     result in SA.
+*
+      CALL ZLAG2C(N,N,A,LDA,SWORK(PTSA),N,INFO)
+*
+      IF (INFO.NE.0) THEN
+          ITER = -2
+          GO TO 40
+      END IF
+*
+*     Compute the LU factorization of SA.
+*
+      CALL CGETRF(N,N,SWORK(PTSA),N,IPIV,INFO)
+*
+      IF (INFO.NE.0) THEN
+          ITER = -3
+          GO TO 40
+      END IF
+*
+*     Solve the system SA*SX = SB.
+*
+      CALL CGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+     +            SWORK(PTSX),N,INFO)
+*
+*     Convert SX back to double precision
+*
+      CALL CLAG2Z(N,NRHS,SWORK(PTSX),N,X,LDX,INFO)
+*
+*     Compute R = B - AX (R is WORK).
+*
+      CALL ZLACPY('All',N,NRHS,B,LDB,WORK,N)
+*
+      CALL ZGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,LDA,X,
+     +           LDX,ONE,WORK,N)
+*
+*     Check whether the NRHS normwised backward errors satisfy the
+*     stopping criterion. If yes, set ITER=0 and return.
+*
+      DO I = 1,NRHS
+          XNRM = CABS1(X(IZAMAX(N,X(1,I),1),I))
+          RNRM = CABS1(WORK(IZAMAX(N,WORK(1,I),1),I))
+          IF (RNRM.GT.XNRM*CTE) GOTO 10
+      END DO
+*
+*     If we are here, the NRHS normwised backward errors satisfy the
+*     stopping criterion. We are good to exit.
+*
+      ITER = 0
+      RETURN
+*
+   10 CONTINUE
+*
+      DO 30 IITER = 1,ITERMAX
+*
+*         Convert R (in WORK) from double precision to single precision
+*         and store the result in SX.
+*
+          CALL ZLAG2C(N,NRHS,WORK,N,SWORK(PTSX),N,INFO)
+*
+          IF (INFO.NE.0) THEN
+              ITER = -2
+              GO TO 40
+          END IF
+*
+*         Solve the system SA*SX = SR.
+*
+          CALL CGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+     +                SWORK(PTSX),N,INFO)
+*
+*         Convert SX back to double precision and update the current
+*         iterate.
+*
+          CALL CLAG2Z(N,NRHS,SWORK(PTSX),N,WORK,N,INFO)
+*
+          CALL ZAXPY(N*NRHS,ONE,WORK,1,X,1)
+*
+*         Compute R = B - AX (R is WORK).
+*
+          CALL ZLACPY('All',N,NRHS,B,LDB,WORK,N)
+*
+          CALL ZGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,
+     +               LDA,X,LDX,ONE,WORK,N)
+*
+*         Check whether the NRHS normwised backward errors satisfy the
+*         stopping criterion. If yes, set ITER=IITER>0 and return.
+*
+          DO I = 1,NRHS
+              XNRM = CABS1(X(IZAMAX(N,X(1,I),1),I))
+              RNRM = CABS1(WORK(IZAMAX(N,WORK(1,I),1),I))
+              IF (RNRM.GT.XNRM*CTE) GOTO 20
+          END DO
+*
+*         If we are here, the NRHS normwised backward errors satisfy the 
+*         stopping criterion, we are good to exit.
+*
+          ITER = IITER
+*
+          RETURN
+*
+   20     CONTINUE
+*
+   30 CONTINUE
+*
+*     If we are at this place of the code, this is because we have
+*     performed ITER=ITERMAX iterations and never satisified the stopping
+*     criterion, set up the ITER flag accordingly and follow up on double
+*     precision routine.
+*
+      ITER = -ITERMAX - 1
+*
+   40 CONTINUE
+*
+*     Single-precision iterative refinement failed to converge to a
+*     satisfactory solution, so we resort to double precision.
+*
+      CALL ZGETRF(N,N,A,LDA,IPIV,INFO)
+*
+      CALL ZLACPY('All',N,NRHS,B,LDB,X,LDX)
+*
+      IF (INFO.EQ.0) THEN
+          CALL ZGETRS('No transpose',N,NRHS,A,LDA,IPIV,X,LDX,INFO)
+      END IF
+*
+      RETURN
+*
+*     End of ZCGESV.
+*
+      END
diff --git a/SRC/zdrscl.f b/SRC/zdrscl.f
new file mode 100644
index 00000000..11686d0b
--- /dev/null
+++ b/SRC/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/zgbbrd.f b/SRC/zgbbrd.f
new file mode 100644
index 00000000..55fcb282
--- /dev/null
+++ b/SRC/zgbbrd.f
@@ -0,0 +1,465 @@
+      SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
+     $                   LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), C( LDC, * ), PT( LDPT, * ),
+     $                   Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBBRD reduces a complex general m-by-n band matrix A to real upper
+*  bidiagonal form B by a unitary transformation: Q' * A * P = B.
+*
+*  The routine computes B, and optionally forms Q or P', or computes
+*  Q'*C for a given matrix C.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          Specifies whether or not the matrices Q and P' are to be
+*          formed.
+*          = 'N': do not form Q or P';
+*          = 'Q': form Q only;
+*          = 'P': form P' only;
+*          = 'B': form both.
+*
+*  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.
+*
+*  NCC     (input) INTEGER
+*          The number of columns of the matrix C.  NCC >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals of the matrix A. KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals of the matrix A. KU >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the m-by-n band matrix A, stored in rows 1 to
+*          KL+KU+1. The j-th column of A is stored in the j-th column of
+*          the array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*          On exit, A is overwritten by values generated during the
+*          reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A. LDAB >= KL+KU+1.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B.
+*
+*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+*          The superdiagonal elements of the bidiagonal matrix B.
+*
+*  Q       (output) COMPLEX*16 array, dimension (LDQ,M)
+*          If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
+*          If VECT = 'N' or 'P', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
+*
+*  PT      (output) COMPLEX*16 array, dimension (LDPT,N)
+*          If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
+*          If VECT = 'N' or 'Q', the array PT is not referenced.
+*
+*  LDPT    (input) INTEGER
+*          The leading dimension of the array PT.
+*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,NCC)
+*          On entry, an m-by-ncc matrix C.
+*          On exit, C is overwritten by Q'*C.
+*          C is not referenced if NCC = 0.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C.
+*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (max(M,N))
+*
+*  RWORK   (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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTB, WANTC, WANTPT, WANTQ
+      INTEGER            I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
+     $                   KUN, L, MINMN, ML, ML0, MU, MU0, NR, NRT
+      DOUBLE PRECISION   ABST, RC
+      COMPLEX*16         RA, RB, RS, T
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARGV, ZLARTG, ZLARTV, ZLASET, ZROT,
+     $                   ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCONJG, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTB = LSAME( VECT, 'B' )
+      WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
+      WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
+      WANTC = NCC.GT.0
+      KLU1 = KL + KU + 1
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KLU1 ) THEN
+         INFO = -8
+      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
+         INFO = -12
+      ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBBRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and P' to the unit matrix, if needed
+*
+      IF( WANTQ )
+     $   CALL ZLASET( 'Full', M, M, CZERO, CONE, Q, LDQ )
+      IF( WANTPT )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, PT, LDPT )
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      MINMN = MIN( M, N )
+*
+      IF( KL+KU.GT.1 ) THEN
+*
+*        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
+*        first to lower bidiagonal form and then transform to upper
+*        bidiagonal
+*
+         IF( KU.GT.0 ) THEN
+            ML0 = 1
+            MU0 = 2
+         ELSE
+            ML0 = 2
+            MU0 = 1
+         END IF
+*
+*        Wherever possible, plane rotations are generated and applied in
+*        vector operations of length NR over the index set J1:J2:KLU1.
+*
+*        The complex sines of the plane rotations are stored in WORK,
+*        and the real cosines in RWORK.
+*
+         KLM = MIN( M-1, KL )
+         KUN = MIN( N-1, KU )
+         KB = KLM + KUN
+         KB1 = KB + 1
+         INCA = KB1*LDAB
+         NR = 0
+         J1 = KLM + 2
+         J2 = 1 - KUN
+*
+         DO 90 I = 1, MINMN
+*
+*           Reduce i-th column and i-th row of matrix to bidiagonal form
+*
+            ML = KLM + 1
+            MU = KUN + 1
+            DO 80 KK = 1, KB
+               J1 = J1 + KB
+               J2 = J2 + KB
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been created below the band
+*
+               IF( NR.GT.0 )
+     $            CALL ZLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
+     $                         WORK( J1 ), KB1, RWORK( J1 ), KB1 )
+*
+*              apply plane rotations from the left
+*
+               DO 10 L = 1, KB
+                  IF( J2-KLM+L-1.GT.N ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL ZLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
+     $                            AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
+     $                            RWORK( J1 ), WORK( J1 ), KB1 )
+   10          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  IF( ML.LE.M-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i+ml-1,i)
+*                    within the band, and apply rotation from the left
+*
+                     CALL ZLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
+     $                            RWORK( I+ML-1 ), WORK( I+ML-1 ), RA )
+                     AB( KU+ML-1, I ) = RA
+                     IF( I.LT.N )
+     $                  CALL ZROT( MIN( KU+ML-2, N-I ),
+     $                             AB( KU+ML-2, I+1 ), LDAB-1,
+     $                             AB( KU+ML-1, I+1 ), LDAB-1,
+     $                             RWORK( I+ML-1 ), WORK( I+ML-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTQ ) THEN
+*
+*                 accumulate product of plane rotations in Q
+*
+                  DO 20 J = J1, J2, KB1
+                     CALL ZROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                          RWORK( J ), DCONJG( WORK( J ) ) )
+   20             CONTINUE
+               END IF
+*
+               IF( WANTC ) THEN
+*
+*                 apply plane rotations to C
+*
+                  DO 30 J = J1, J2, KB1
+                     CALL ZROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
+     $                          RWORK( J ), WORK( J ) )
+   30             CONTINUE
+               END IF
+*
+               IF( J2+KUN.GT.N ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 40 J = J1, J2, KB1
+*
+*                 create nonzero element a(j-1,j+ku) above the band
+*                 and store it in WORK(n+1:2*n)
+*
+                  WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
+                  AB( 1, J+KUN ) = RWORK( J )*AB( 1, J+KUN )
+   40          CONTINUE
+*
+*              generate plane rotations to annihilate nonzero elements
+*              which have been generated above the band
+*
+               IF( NR.GT.0 )
+     $            CALL ZLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
+     $                         WORK( J1+KUN ), KB1, RWORK( J1+KUN ),
+     $                         KB1 )
+*
+*              apply plane rotations from the right
+*
+               DO 50 L = 1, KB
+                  IF( J2+L-1.GT.M ) THEN
+                     NRT = NR - 1
+                  ELSE
+                     NRT = NR
+                  END IF
+                  IF( NRT.GT.0 )
+     $               CALL ZLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
+     $                            AB( L, J1+KUN ), INCA,
+     $                            RWORK( J1+KUN ), WORK( J1+KUN ), KB1 )
+   50          CONTINUE
+*
+               IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
+                  IF( MU.LE.N-I+1 ) THEN
+*
+*                    generate plane rotation to annihilate a(i,i+mu-1)
+*                    within the band, and apply rotation from the right
+*
+                     CALL ZLARTG( AB( KU-MU+3, I+MU-2 ),
+     $                            AB( KU-MU+2, I+MU-1 ),
+     $                            RWORK( I+MU-1 ), WORK( I+MU-1 ), RA )
+                     AB( KU-MU+3, I+MU-2 ) = RA
+                     CALL ZROT( MIN( KL+MU-2, M-I ),
+     $                          AB( KU-MU+4, I+MU-2 ), 1,
+     $                          AB( KU-MU+3, I+MU-1 ), 1,
+     $                          RWORK( I+MU-1 ), WORK( I+MU-1 ) )
+                  END IF
+                  NR = NR + 1
+                  J1 = J1 - KB1
+               END IF
+*
+               IF( WANTPT ) THEN
+*
+*                 accumulate product of plane rotations in P'
+*
+                  DO 60 J = J1, J2, KB1
+                     CALL ZROT( N, PT( J+KUN-1, 1 ), LDPT,
+     $                          PT( J+KUN, 1 ), LDPT, RWORK( J+KUN ),
+     $                          DCONJG( WORK( J+KUN ) ) )
+   60             CONTINUE
+               END IF
+*
+               IF( J2+KB.GT.M ) THEN
+*
+*                 adjust J2 to keep within the bounds of the matrix
+*
+                  NR = NR - 1
+                  J2 = J2 - KB1
+               END IF
+*
+               DO 70 J = J1, J2, KB1
+*
+*                 create nonzero element a(j+kl+ku,j+ku-1) below the
+*                 band and store it in WORK(1:n)
+*
+                  WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
+                  AB( KLU1, J+KUN ) = RWORK( J+KUN )*AB( KLU1, J+KUN )
+   70          CONTINUE
+*
+               IF( ML.GT.ML0 ) THEN
+                  ML = ML - 1
+               ELSE
+                  MU = MU - 1
+               END IF
+   80       CONTINUE
+   90    CONTINUE
+      END IF
+*
+      IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
+*
+*        A has been reduced to complex lower bidiagonal form
+*
+*        Transform lower bidiagonal form to upper bidiagonal by applying
+*        plane rotations from the left, overwriting superdiagonal
+*        elements on subdiagonal elements
+*
+         DO 100 I = 1, MIN( M-1, N )
+            CALL ZLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
+            AB( 1, I ) = RA
+            IF( I.LT.N ) THEN
+               AB( 2, I ) = RS*AB( 1, I+1 )
+               AB( 1, I+1 ) = RC*AB( 1, I+1 )
+            END IF
+            IF( WANTQ )
+     $         CALL ZROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC,
+     $                    DCONJG( RS ) )
+            IF( WANTC )
+     $         CALL ZROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
+     $                    RS )
+  100    CONTINUE
+      ELSE
+*
+*        A has been reduced to complex upper bidiagonal form or is
+*        diagonal
+*
+         IF( KU.GT.0 .AND. M.LT.N ) THEN
+*
+*           Annihilate a(m,m+1) by applying plane rotations from the
+*           right
+*
+            RB = AB( KU, M+1 )
+            DO 110 I = M, 1, -1
+               CALL ZLARTG( AB( KU+1, I ), RB, RC, RS, RA )
+               AB( KU+1, I ) = RA
+               IF( I.GT.1 ) THEN
+                  RB = -DCONJG( RS )*AB( KU, I )
+                  AB( KU, I ) = RC*AB( KU, I )
+               END IF
+               IF( WANTPT )
+     $            CALL ZROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
+     $                       RC, DCONJG( RS ) )
+  110       CONTINUE
+         END IF
+      END IF
+*
+*     Make diagonal and superdiagonal elements real, storing them in D
+*     and E
+*
+      T = AB( KU+1, 1 )
+      DO 120 I = 1, MINMN
+         ABST = ABS( T )
+         D( I ) = ABST
+         IF( ABST.NE.ZERO ) THEN
+            T = T / ABST
+         ELSE
+            T = CONE
+         END IF
+         IF( WANTQ )
+     $      CALL ZSCAL( M, T, Q( 1, I ), 1 )
+         IF( WANTC )
+     $      CALL ZSCAL( NCC, DCONJG( T ), C( I, 1 ), LDC )
+         IF( I.LT.MINMN ) THEN
+            IF( KU.EQ.0 .AND. KL.EQ.0 ) THEN
+               E( I ) = ZERO
+               T = AB( 1, I+1 )
+            ELSE
+               IF( KU.EQ.0 ) THEN
+                  T = AB( 2, I )*DCONJG( T )
+               ELSE
+                  T = AB( KU, I+1 )*DCONJG( T )
+               END IF
+               ABST = ABS( T )
+               E( I ) = ABST
+               IF( ABST.NE.ZERO ) THEN
+                  T = T / ABST
+               ELSE
+                  T = CONE
+               END IF
+               IF( WANTPT )
+     $            CALL ZSCAL( N, T, PT( I+1, 1 ), LDPT )
+               T = AB( KU+1, I+1 )*DCONJG( T )
+            END IF
+         END IF
+  120 CONTINUE
+      RETURN
+*
+*     End of ZGBBRD
+*
+      END
diff --git a/SRC/zgbcon.f b/SRC/zgbcon.f
new file mode 100644
index 00000000..b99cfe29
--- /dev/null
+++ b/SRC/zgbcon.f
@@ -0,0 +1,234 @@
+      SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, 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, KL, KU, LDAB, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBCON estimates the reciprocal of the condition number of a complex
+*  general band matrix A, in either the 1-norm or the infinity-norm,
+*  using the LU factorization computed by ZGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by ZGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= N, row i of the matrix was
+*          interchanged with row IPIV(i).
+*
+*  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 (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            LNOTI, ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, J, JP, KASE, KASE1, KD, LM
+      DOUBLE PRECISION   AINVNM, SCALE, SMLNUM
+      COMPLEX*16         T, ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, IZAMAX, DLAMCH, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZDRSCL, ZLACN2, ZLATBS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MIN
+*     ..
+*     .. 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( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the norm of inv(A).
+*
+      AINVNM = ZERO
+      NORMIN = 'N'
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KD = KL + KU + 1
+      LNOTI = KL.GT.0
+      KASE = 0
+   10 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            IF( LNOTI ) THEN
+               DO 20 J = 1, N - 1
+                  LM = MIN( KL, N-J )
+                  JP = IPIV( J )
+                  T = WORK( JP )
+                  IF( JP.NE.J ) THEN
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+                  CALL ZAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
+   20          CONTINUE
+            END IF
+*
+*           Multiply by inv(U).
+*
+            CALL ZLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KL+KU, AB, LDAB, WORK, SCALE, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL ZLATBS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, KL+KU, AB, LDAB, WORK, SCALE, RWORK,
+     $                   INFO )
+*
+*           Multiply by inv(L').
+*
+            IF( LNOTI ) THEN
+               DO 30 J = N - 1, 1, -1
+                  LM = MIN( KL, N-J )
+                  WORK( J ) = WORK( J ) - ZDOTC( LM, AB( KD+1, J ), 1,
+     $                        WORK( J+1 ), 1 )
+                  JP = IPIV( J )
+                  IF( JP.NE.J ) THEN
+                     T = WORK( JP )
+                     WORK( JP ) = WORK( J )
+                     WORK( J ) = T
+                  END IF
+   30          CONTINUE
+            END IF
+         END IF
+*
+*        Divide X by 1/SCALE if doing so will not cause overflow.
+*
+         NORMIN = 'Y'
+         IF( SCALE.NE.ONE ) THEN
+            IX = IZAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 40
+            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
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of ZGBCON
+*
+      END
diff --git a/SRC/zgbequ.f b/SRC/zgbequ.f
new file mode 100644
index 00000000..cb674acc
--- /dev/null
+++ b/SRC/zgbequ.f
@@ -0,0 +1,247 @@
+      SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, 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, KL, KU, LDAB, M, N
+      DOUBLE PRECISION   AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), R( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBEQU computes row and column scalings intended to equilibrate an
+*  M-by-N band matrix A and reduce its condition number.  R returns the
+*  row scale factors and C the column scale factors, chosen to try to
+*  make the largest element in each row and column of the matrix B with
+*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+*  number and BIGNUM = largest safe number.  Use of these scaling
+*  factors is not guaranteed to reduce the condition number of A but
+*  works well in practice.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  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, KD
+      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
+      COMPLEX*16         ZDUM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         ROWCND = ONE
+         COLCND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+*     Compute row scale factors.
+*
+      DO 10 I = 1, M
+         R( I ) = ZERO
+   10 CONTINUE
+*
+*     Find the maximum element in each row.
+*
+      KD = KU + 1
+      DO 30 J = 1, N
+         DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            R( I ) = MAX( R( I ), CABS1( AB( KD+I-J, J ) ) )
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 40 I = 1, M
+         RCMAX = MAX( RCMAX, R( I ) )
+         RCMIN = MIN( RCMIN, R( I ) )
+   40 CONTINUE
+      AMAX = RCMAX
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 50 I = 1, M
+            IF( R( I ).EQ.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   50    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 60 I = 1, M
+            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+   60    CONTINUE
+*
+*        Compute ROWCND = min(R(I)) / max(R(I))
+*
+         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+*     Compute column scale factors
+*
+      DO 70 J = 1, N
+         C( J ) = ZERO
+   70 CONTINUE
+*
+*     Find the maximum element in each column,
+*     assuming the row scaling computed above.
+*
+      KD = KU + 1
+      DO 90 J = 1, N
+         DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+            C( J ) = MAX( C( J ), CABS1( AB( KD+I-J, J ) )*R( I ) )
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 100 J = 1, N
+         RCMIN = MIN( RCMIN, C( J ) )
+         RCMAX = MAX( RCMAX, C( J ) )
+  100 CONTINUE
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 110 J = 1, N
+            IF( C( J ).EQ.ZERO ) THEN
+               INFO = M + J
+               RETURN
+            END IF
+  110    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 120 J = 1, N
+            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+  120    CONTINUE
+*
+*        Compute COLCND = min(C(J)) / max(C(J))
+*
+         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+      RETURN
+*
+*     End of ZGBEQU
+*
+      END
diff --git a/SRC/zgbrfs.f b/SRC/zgbrfs.f
new file mode 100644
index 00000000..045b6a25
--- /dev/null
+++ b/SRC/zgbrfs.f
@@ -0,0 +1,365 @@
+      SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   IPIV, B, LDB, X, LDX, FERR, BERR, 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          TRANS
+      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is banded, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The original band matrix A, stored in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by ZGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from ZGBTRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZGBTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, K, KASE, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGBMV, ZGBTRS, ZLACN2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -9
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( KL+KU+2, N+1 )
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZGBMV( TRANS, N, N, KL, KU, -CONE, AB, LDAB, X( 1, J ), 1,
+     $               CONE, WORK, 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
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               KK = KU + 1 - K
+               XK = CABS1( X( K, J ) )
+               DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  RWORK( I ) = RWORK( I ) + CABS1( AB( KK+I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               KK = KU + 1 - K
+               DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
+                  S = S + CABS1( AB( KK+I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, WORK, N,
+     $                   INFO )
+            CALL ZAXPY( N, CONE, WORK, 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 ZLACN2 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( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL ZGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZGBTRS( TRANSN, N, KL, KU, 1, AFB, LDAFB, IPIV,
+     $                      WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZGBRFS
+*
+      END
diff --git a/SRC/zgbsv.f b/SRC/zgbsv.f
new file mode 100644
index 00000000..92db215c
--- /dev/null
+++ b/SRC/zgbsv.f
@@ -0,0 +1,142 @@
+      SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBSV computes the solution to a complex system of linear equations
+*  A * X = B, where A is a band matrix of order N with KL subdiagonals
+*  and KU superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  The LU decomposition with partial pivoting and row interchanges is
+*  used to factor A as A = L * U, where L is a product of permutation
+*  and unit lower triangular matrices with KL subdiagonals, and U is
+*  upper triangular with KL+KU superdiagonals.  The factored form of A
+*  is then used to solve the system of equations A * X = B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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) COMPLEX*16 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).
+*
+*  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 the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGBTRF, ZGBTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of the band matrix A.
+*
+      CALL ZGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
+     $                B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of ZGBSV
+*
+      END
diff --git a/SRC/zgbsvx.f b/SRC/zgbsvx.f
new file mode 100644
index 00000000..bb8e8163
--- /dev/null
+++ b/SRC/zgbsvx.f
@@ -0,0 +1,517 @@
+      SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
+     $                   LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, RWORK, 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, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBSVX uses the LU factorization to compute the solution to a complex
+*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+*  where A is a band matrix of order N with KL subdiagonals and KU
+*  superdiagonals, and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed by this subroutine:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
+*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+*     or diag(C)*B (if TRANS = 'T' or 'C').
+*
+*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+*     matrix A (after equilibration if FACT = 'E') as
+*        A = L * U,
+*     where L is a product of permutation and unit lower triangular
+*     matrices with KL subdiagonals, and U is upper triangular with
+*     KL+KU superdiagonals.
+*
+*  3. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+*     that it solves the original system before equilibration.
+*
+*  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, AFB and IPIV contain the factored form of
+*                  A.  If EQUED is not 'N', the matrix A has been
+*                  equilibrated with scaling factors given by R and C.
+*                  AB, AFB, and IPIV are not modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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 number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
+*
+*          If FACT = 'F' and EQUED is not 'N', then A must have been
+*          equilibrated by the scaling factors in R and/or C.  AB is not
+*          modified if FACT = 'F' or 'N', or if FACT = 'E' and
+*          EQUED = 'N' on exit.
+*
+*          On exit, if EQUED .ne. 'N', A is scaled as follows:
+*          EQUED = 'R':  A := diag(R) * A
+*          EQUED = 'C':  A := A * diag(C)
+*          EQUED = 'B':  A := diag(R) * A * diag(C).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+1.
+*
+*  AFB     (input or output) COMPLEX*16 array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains details of the LU factorization of the band matrix
+*          A, as computed by ZGBTRF.  U is stored as an upper triangular
+*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
+*          and the multipliers used during the factorization are stored
+*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is
+*          the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns details of the LU factorization of A.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns details of the LU factorization of the equilibrated
+*          matrix A (see the description of AB for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.
+*
+*  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 = L*U
+*          as computed by ZGBTRF; row i of the matrix was interchanged
+*          with row IPIV(i).
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the original matrix A.
+*
+*          If FACT = 'E', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = L*U
+*          of the equilibrated matrix A.
+*
+*  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) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit,
+*          if EQUED = 'N', B is not modified;
+*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+*          diag(R)*B;
+*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+*          overwritten by diag(C)*B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 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) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (N)
+*          On exit, RWORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If RWORK(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
+*          RWORK(1) contains the reciprocal pivot growth factor for the
+*          leading INFO columns of A.
+*
+*  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.
+*
+*  =====================================================================
+*  Moved setting of INFO = N+1 so INFO does not subsequently get
+*  overwritten.  Sven, 17 Mar 05. 
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+      CHARACTER          NORM
+      INTEGER            I, INFEQU, J, J1, J2
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANGB, ZLANTB
+      EXTERNAL           LSAME, DLAMCH, ZLANGB, ZLANTB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZGBCON, ZGBEQU, ZGBRFS, ZGBTRF,
+     $                   ZGBTRS, ZLACPY, ZLAQGB
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         ROWEQU = .FALSE.
+         COLEQU = .FALSE.
+      ELSE
+         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+         INFO = -8
+      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+         INFO = -10
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -12
+      ELSE
+         IF( ROWEQU ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 10 J = 1, N
+               RCMIN = MIN( RCMIN, R( J ) )
+               RCMAX = MAX( RCMAX, R( J ) )
+   10       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -13
+            ELSE IF( N.GT.0 ) THEN
+               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               ROWCND = ONE
+            END IF
+         END IF
+         IF( COLEQU .AND. INFO.EQ.0 ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 20 J = 1, N
+               RCMIN = MIN( RCMIN, C( J ) )
+               RCMAX = MAX( RCMAX, C( J ) )
+   20       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -14
+            ELSE IF( N.GT.0 ) THEN
+               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               COLCND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -16
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -18
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL ZGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL ZLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+     $                   AMAX, EQUED )
+            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( NOTRAN ) THEN
+         IF( ROWEQU ) THEN
+            DO 40 J = 1, NRHS
+               DO 30 I = 1, N
+                  B( I, J ) = R( I )*B( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( COLEQU ) THEN
+         DO 60 J = 1, NRHS
+            DO 50 I = 1, N
+               B( I, J ) = C( I )*B( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the LU factorization of the band matrix A.
+*
+         DO 70 J = 1, N
+            J1 = MAX( J-KU, 1 )
+            J2 = MIN( J+KL, N )
+            CALL ZCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
+     $                  AFB( KL+KU+1-J+J1, J ), 1 )
+   70    CONTINUE
+*
+         CALL ZGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 ) THEN
+*
+*           Compute the reciprocal pivot growth factor of the
+*           leading rank-deficient INFO columns of A.
+*
+            ANORM = ZERO
+            DO 90 J = 1, INFO
+               DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+                  ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
+   80          CONTINUE
+   90       CONTINUE
+            RPVGRW = ZLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
+     $                       AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
+     $                       RWORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = ANORM / RPVGRW
+            END IF
+            RWORK( 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 = ZLANGB( NORM, N, KL, KU, AB, LDAB, RWORK )
+      RPVGRW = ZLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, RWORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = ZLANGB( 'M', N, KL, KU, AB, LDAB, RWORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
+     $             WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( NOTRAN ) THEN
+         IF( COLEQU ) THEN
+            DO 110 J = 1, NRHS
+               DO 100 I = 1, N
+                  X( I, J ) = C( I )*X( I, J )
+  100          CONTINUE
+  110       CONTINUE
+            DO 120 J = 1, NRHS
+               FERR( J ) = FERR( J ) / COLCND
+  120       CONTINUE
+         END IF
+      ELSE IF( ROWEQU ) THEN
+         DO 140 J = 1, NRHS
+            DO 130 I = 1, N
+               X( I, J ) = R( I )*X( I, J )
+  130       CONTINUE
+  140    CONTINUE
+         DO 150 J = 1, NRHS
+            FERR( J ) = FERR( J ) / ROWCND
+  150    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RWORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of ZGBSVX
+*
+      END
diff --git a/SRC/zgbtf2.f b/SRC/zgbtf2.f
new file mode 100644
index 00000000..e722d54e
--- /dev/null
+++ b/SRC/zgbtf2.f
@@ -0,0 +1,202 @@
+      SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
+*  A using partial pivoting with row interchanges.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U, because of fill-in resulting from the row
+*  interchanges.
+*
+*  =====================================================================
+*
+*     .. 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, JP, JU, KM, KV
+*     ..
+*     .. External Functions ..
+      INTEGER            IZAMAX
+      EXTERNAL           IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in.
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Gaussian elimination with partial pivoting
+*
+*     Set fill-in elements in columns KU+2 to KV to zero.
+*
+      DO 20 J = KU + 2, MIN( KV, N )
+         DO 10 I = KV - J + 2, KL
+            AB( I, J ) = ZERO
+   10    CONTINUE
+   20 CONTINUE
+*
+*     JU is the index of the last column affected by the current stage
+*     of the factorization.
+*
+      JU = 1
+*
+      DO 40 J = 1, MIN( M, N )
+*
+*        Set fill-in elements in column J+KV to zero.
+*
+         IF( J+KV.LE.N ) THEN
+            DO 30 I = 1, KL
+               AB( I, J+KV ) = ZERO
+   30       CONTINUE
+         END IF
+*
+*        Find pivot and test for singularity. KM is the number of
+*        subdiagonal elements in the current column.
+*
+         KM = MIN( KL, M-J )
+         JP = IZAMAX( KM+1, AB( KV+1, J ), 1 )
+         IPIV( J ) = JP + J - 1
+         IF( AB( KV+JP, J ).NE.ZERO ) THEN
+            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
+*
+*           Apply interchange to columns J to JU.
+*
+            IF( JP.NE.1 )
+     $         CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
+     $                     AB( KV+1, J ), LDAB-1 )
+            IF( KM.GT.0 ) THEN
+*
+*              Compute multipliers.
+*
+               CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
+*
+*              Update trailing submatrix within the band.
+*
+               IF( JU.GT.J )
+     $            CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1,
+     $                        AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
+     $                        LDAB-1 )
+            END IF
+         ELSE
+*
+*           If pivot is zero, set INFO to the index of the pivot
+*           unless a zero pivot has already been found.
+*
+            IF( INFO.EQ.0 )
+     $         INFO = J
+         END IF
+   40 CONTINUE
+      RETURN
+*
+*     End of ZGBTF2
+*
+      END
diff --git a/SRC/zgbtrf.f b/SRC/zgbtrf.f
new file mode 100644
index 00000000..3d6f21ad
--- /dev/null
+++ b/SRC/zgbtrf.f
@@ -0,0 +1,442 @@
+      SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KL, KU, LDAB, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
+*  using partial pivoting with row interchanges.
+*
+*  This is the blocked version of the algorithm, calling 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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows KL+1 to
+*          2*KL+KU+1; rows 1 to KL of the array need not be set.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, details of the factorization: U is stored as an
+*          upper triangular band matrix with KL+KU superdiagonals in
+*          rows 1 to KL+KU+1, and the multipliers used during the
+*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+*          See below for further details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  M = N = 6, KL = 2, KU = 1:
+*
+*  On entry:                       On exit:
+*
+*      *    *    *    +    +    +       *    *    *   u14  u25  u36
+*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
+*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
+*
+*  Array elements marked * are not used by the routine; elements marked
+*  + need not be set on entry, but are required by the routine to store
+*  elements of U because of fill-in resulting from the row interchanges.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
+     $                   JU, K2, KM, KV, NB, NW
+      COMPLEX*16         TEMP
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         WORK13( LDWORK, NBMAX ),
+     $                   WORK31( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV, IZAMAX
+      EXTERNAL           ILAENV, IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP,
+     $                   ZSCAL, ZSWAP, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     KV is the number of superdiagonals in the factor U, allowing for
+*     fill-in
+*
+      KV = KU + KL
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBTRF', -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, 'ZGBTRF', ' ', M, N, KL, KU )
+*
+*     The block size must not exceed the limit set by the size of the
+*     local arrays WORK13 and WORK31.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+*        Zero the superdiagonal elements of the work array WORK13
+*
+         DO 20 J = 1, NB
+            DO 10 I = 1, J - 1
+               WORK13( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+*
+*        Zero the subdiagonal elements of the work array WORK31
+*
+         DO 40 J = 1, NB
+            DO 30 I = J + 1, NB
+               WORK31( I, J ) = ZERO
+   30       CONTINUE
+   40    CONTINUE
+*
+*        Gaussian elimination with partial pivoting
+*
+*        Set fill-in elements in columns KU+2 to KV to zero
+*
+         DO 60 J = KU + 2, MIN( KV, N )
+            DO 50 I = KV - J + 2, KL
+               AB( I, J ) = ZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+*        JU is the index of the last column affected by the current
+*        stage of the factorization
+*
+         JU = 1
+*
+         DO 180 J = 1, MIN( M, N ), NB
+            JB = MIN( NB, MIN( M, N )-J+1 )
+*
+*           The active part of the matrix is partitioned
+*
+*              A11   A12   A13
+*              A21   A22   A23
+*              A31   A32   A33
+*
+*           Here A11, A21 and A31 denote the current block of JB columns
+*           which is about to be factorized. The number of rows in the
+*           partitioning are JB, I2, I3 respectively, and the numbers
+*           of columns are JB, J2, J3. The superdiagonal elements of A13
+*           and the subdiagonal elements of A31 lie outside the band.
+*
+            I2 = MIN( KL-JB, M-J-JB+1 )
+            I3 = MIN( JB, M-J-KL+1 )
+*
+*           J2 and J3 are computed after JU has been updated.
+*
+*           Factorize the current block of JB columns
+*
+            DO 80 JJ = J, J + JB - 1
+*
+*              Set fill-in elements in column JJ+KV to zero
+*
+               IF( JJ+KV.LE.N ) THEN
+                  DO 70 I = 1, KL
+                     AB( I, JJ+KV ) = ZERO
+   70             CONTINUE
+               END IF
+*
+*              Find pivot and test for singularity. KM is the number of
+*              subdiagonal elements in the current column.
+*
+               KM = MIN( KL, M-JJ )
+               JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 )
+               IPIV( JJ ) = JP + JJ - J
+               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
+                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
+                  IF( JP.NE.1 ) THEN
+*
+*                    Apply interchange to columns J to J+JB-1
+*
+                     IF( JP+JJ-1.LT.J+KL ) THEN
+*
+                        CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              AB( KV+JP+JJ-J, J ), LDAB-1 )
+                     ELSE
+*
+*                       The interchange affects columns J to JJ-1 of A31
+*                       which are stored in the work array WORK31
+*
+                        CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                        CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
+     $                              AB( KV+JP, JJ ), LDAB-1 )
+                     END IF
+                  END IF
+*
+*                 Compute multipliers
+*
+                  CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
+     $                        1 )
+*
+*                 Update trailing submatrix within the band and within
+*                 the current block. JM is the index of the last column
+*                 which needs to be updated.
+*
+                  JM = MIN( JU, J+JB-1 )
+                  IF( JM.GT.JJ )
+     $               CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
+     $                           AB( KV, JJ+1 ), LDAB-1,
+     $                           AB( KV+1, JJ+1 ), LDAB-1 )
+               ELSE
+*
+*                 If pivot is zero, set INFO to the index of the pivot
+*                 unless a zero pivot has already been found.
+*
+                  IF( INFO.EQ.0 )
+     $               INFO = JJ
+               END IF
+*
+*              Copy current column of A31 into the work array WORK31
+*
+               NW = MIN( JJ-J+1, I3 )
+               IF( NW.GT.0 )
+     $            CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
+     $                        WORK31( 1, JJ-J+1 ), 1 )
+   80       CONTINUE
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply the row interchanges to the other blocks.
+*
+               J2 = MIN( JU-J+1, KV ) - JB
+               J3 = MAX( 0, JU-J-KV+1 )
+*
+*              Use ZLASWP to apply the row interchanges to A12, A22, and
+*              A32.
+*
+               CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
+     $                      IPIV( J ), 1 )
+*
+*              Adjust the pivot indices.
+*
+               DO 90 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+   90          CONTINUE
+*
+*              Apply the row interchanges to A13, A23, and A33
+*              columnwise.
+*
+               K2 = J - 1 + JB + J2
+               DO 110 I = 1, J3
+                  JJ = K2 + I
+                  DO 100 II = J + I - 1, J + JB - 1
+                     IP = IPIV( II )
+                     IF( IP.NE.II ) THEN
+                        TEMP = AB( KV+1+II-JJ, JJ )
+                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
+                        AB( KV+1+IP-JJ, JJ ) = TEMP
+                     END IF
+  100             CONTINUE
+  110          CONTINUE
+*
+*              Update the relevant part of the trailing submatrix
+*
+               IF( J2.GT.0 ) THEN
+*
+*                 Update A12
+*
+                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,
+     $                        AB( KV+1-JB, J+JB ), LDAB-1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A22
+*
+                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J2,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+1, J+JB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A32
+*
+                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J2,
+     $                           JB, -ONE, WORK31, LDWORK,
+     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
+                  END IF
+               END IF
+*
+               IF( J3.GT.0 ) THEN
+*
+*                 Copy the lower triangle of A13 into the work array
+*                 WORK13
+*
+                  DO 130 JJ = 1, J3
+                     DO 120 II = JJ, JB
+                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
+  120                CONTINUE
+  130             CONTINUE
+*
+*                 Update A13 in the work array
+*
+                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,
+     $                        WORK13, LDWORK )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A23
+*
+                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J3,
+     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
+     $                           LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Update A33
+*
+                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J3,
+     $                           JB, -ONE, WORK31, LDWORK, WORK13,
+     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
+                  END IF
+*
+*                 Copy the lower triangle of A13 back into place
+*
+                  DO 150 JJ = 1, J3
+                     DO 140 II = JJ, JB
+                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
+  140                CONTINUE
+  150             CONTINUE
+               END IF
+            ELSE
+*
+*              Adjust the pivot indices.
+*
+               DO 160 I = J, J + JB - 1
+                  IPIV( I ) = IPIV( I ) + J - 1
+  160          CONTINUE
+            END IF
+*
+*           Partially undo the interchanges in the current block to
+*           restore the upper triangular form of A31 and copy the upper
+*           triangle of A31 back into place
+*
+            DO 170 JJ = J + JB - 1, J, -1
+               JP = IPIV( JJ ) - JJ + 1
+               IF( JP.NE.1 ) THEN
+*
+*                 Apply interchange to columns J to JJ-1
+*
+                  IF( JP+JJ-1.LT.J+KL ) THEN
+*
+*                    The interchange does not affect A31
+*
+                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )
+                  ELSE
+*
+*                    The interchange does affect A31
+*
+                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+                  END IF
+               END IF
+*
+*              Copy the current column of A31 back into place
+*
+               NW = MIN( I3, JJ-J+1 )
+               IF( NW.GT.0 )
+     $            CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
+     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )
+  170       CONTINUE
+  180    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZGBTRF
+*
+      END
diff --git a/SRC/zgbtrs.f b/SRC/zgbtrs.f
new file mode 100644
index 00000000..bd61a861
--- /dev/null
+++ b/SRC/zgbtrs.f
@@ -0,0 +1,214 @@
+      SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, 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, KL, KU, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGBTRS solves a system of linear equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B
+*  with a general band matrix A using the LU factorization computed
+*  by ZGBTRF.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          Details of the LU factorization of the band matrix A, as
+*          computed by ZGBTRF.  U is stored as an upper triangular band
+*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+*          the multipliers used during the factorization are stored in
+*          rows KL+KU+2 to 2*KL+KU+1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; 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            LNOTI, NOTRAN
+      INTEGER            I, J, KD, L, LM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP, ZTBSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KL.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      KD = KU + KL + 1
+      LNOTI = KL.GT.0
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve  A*X = B.
+*
+*        Solve L*X = B, overwriting B with X.
+*
+*        L is represented as a product of permutations and unit lower
+*        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
+*        where each transformation L(i) is a rank-one modification of
+*        the identity matrix.
+*
+         IF( LNOTI ) THEN
+            DO 10 J = 1, N - 1
+               LM = MIN( KL, N-J )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+               CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
+     $                     LDB, B( J+1, 1 ), LDB )
+   10       CONTINUE
+         END IF
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
+     $                  AB, LDAB, B( 1, I ), 1 )
+   20    CONTINUE
+*
+      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*        Solve A**T * X = B.
+*
+         DO 30 I = 1, NRHS
+*
+*           Solve U**T * X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
+     $                  LDAB, B( 1, I ), 1 )
+   30    CONTINUE
+*
+*        Solve L**T * X = B, overwriting B with X.
+*
+         IF( LNOTI ) THEN
+            DO 40 J = N - 1, 1, -1
+               LM = MIN( KL, N-J )
+               CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
+     $                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+   40       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Solve A**H * X = B.
+*
+         DO 50 I = 1, NRHS
+*
+*           Solve U**H * X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
+     $                  KL+KU, AB, LDAB, B( 1, I ), 1 )
+   50    CONTINUE
+*
+*        Solve L**H * X = B, overwriting B with X.
+*
+         IF( LNOTI ) THEN
+            DO 60 J = N - 1, 1, -1
+               LM = MIN( KL, N-J )
+               CALL ZLACGV( NRHS, B( J, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE,
+     $                     B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE,
+     $                     B( J, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( J, 1 ), LDB )
+               L = IPIV( J )
+               IF( L.NE.J )
+     $            CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+   60       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZGBTRS
+*
+      END
diff --git a/SRC/zgebak.f b/SRC/zgebak.f
new file mode 100644
index 00000000..1023601d
--- /dev/null
+++ b/SRC/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/zgebal.f b/SRC/zgebal.f
new file mode 100644
index 00000000..67ac2e14
--- /dev/null
+++ b/SRC/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/zgebd2.f b/SRC/zgebd2.f
new file mode 100644
index 00000000..5ba52e87
--- /dev/null
+++ b/SRC/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/zgebrd.f b/SRC/zgebrd.f
new file mode 100644
index 00000000..4f97bd7e
--- /dev/null
+++ b/SRC/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/zgecon.f b/SRC/zgecon.f
new file mode 100644
index 00000000..cfaaca35
--- /dev/null
+++ b/SRC/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/zgeequ.f b/SRC/zgeequ.f
new file mode 100644
index 00000000..04609ee2
--- /dev/null
+++ b/SRC/zgeequ.f
@@ -0,0 +1,233 @@
+      SUBROUTINE ZGEEQU( 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   C( * ), R( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEEQU 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) COMPLEX*16 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
+      COMPLEX*16         ZDUM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'ZGEEQU', -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 ), CABS1( 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 ), CABS1( 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 ZGEEQU
+*
+      END
diff --git a/SRC/zgees.f b/SRC/zgees.f
new file mode 100644
index 00000000..ade5f9f2
--- /dev/null
+++ b/SRC/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/zgeesx.f b/SRC/zgeesx.f
new file mode 100644
index 00000000..b7567c30
--- /dev/null
+++ b/SRC/zgeesx.f
@@ -0,0 +1,384 @@
+      SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W,
+     $                   VS, LDVS, RCONDE, RCONDV, 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, SENSE, SORT
+      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
+      DOUBLE PRECISION   RCONDE, RCONDV
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEESX 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;
+*  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 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.
+*          An eigenvalue W(j) is selected if SELECT(W(j)) is true.
+*
+*  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) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A is 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, 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) 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).
+*          Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
+*          where SDIM is the number of selected eigenvalues computed by
+*          this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also
+*          that an error is only returned if LWORK < max(1,2*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 bound on the optimal size of the
+*          array WORK, 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 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            SCALEA, WANTSB, WANTSE, WANTSN, WANTST, WANTSV,
+     $                   WANTVS
+      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
+     $                   ITAU, IWRK, LWRK, MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, DLASCL, 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
+      WANTVS = LSAME( JOBVS, 'V' )
+      WANTST = LSAME( SORT, 'S' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+      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 = -11
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of real 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 SENSE = 'E', 'V' or 'B', then the amount of workspace needed
+*       depends on SDIM, which is computed by the routine ZTRSEN later
+*       in the code.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            LWRK = 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
+            LWRK = MAXWRK
+            IF( .NOT.WANTSN )
+     $         LWRK = MAX( LWRK, ( N*N )/2 )
+         END IF
+         WORK( 1 ) = LWRK
+*
+         IF( LWORK.LT.MINWRK ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEESX', -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 = 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, transform Schur vectors, and compute
+*        reciprocal condition numbers
+*        (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM)
+*                     otherwise, need none )
+*        (RWorkspace: none)
+*
+         CALL ZTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
+     $                RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
+     $                ICOND )
+         IF( .NOT.WANTSN )
+     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+         IF( ICOND.EQ.-14 ) THEN
+*
+*           Not enough complex workspace
+*
+            INFO = -15
+         END IF
+      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 )
+         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
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of ZGEESX
+*
+      END
diff --git a/SRC/zgeev.f b/SRC/zgeev.f
new file mode 100644
index 00000000..0fa66307
--- /dev/null
+++ b/SRC/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/zgeevx.f b/SRC/zgeevx.f
new file mode 100644
index 00000000..a4473c48
--- /dev/null
+++ b/SRC/zgeevx.f
@@ -0,0 +1,532 @@
+      SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL,
+     $                   LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE,
+     $                   RCONDV, 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          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
+      DOUBLE PRECISION   ABNRM
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RCONDE( * ), RCONDV( * ), RWORK( * ),
+     $                   SCALE( * )
+      COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
+*  eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+*  Optionally also, it computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
+*  (RCONDE), and reciprocal condition numbers for the right
+*  eigenvectors (RCONDV).
+*
+*  The right eigenvector v(j) of A satisfies
+*                   A * v(j) = lambda(j) * v(j)
+*  where lambda(j) is its eigenvalue.
+*  The left eigenvector u(j) of A satisfies
+*                u(j)**H * A = lambda(j) * u(j)**H
+*  where u(j)**H denotes the conjugate transpose of u(j).
+*
+*  The computed eigenvectors are normalized to have Euclidean norm
+*  equal to 1 and largest component real.
+*
+*  Balancing a matrix means permuting the rows and columns to make it
+*  more nearly upper triangular, and applying a diagonal similarity
+*  transformation D * A * D**(-1), where D is a diagonal matrix, to
+*  make its rows and columns closer in norm and the condition numbers
+*  of its eigenvalues and eigenvectors smaller.  The computed
+*  reciprocal condition numbers correspond to the balanced matrix.
+*  Permuting rows and columns will not change the condition numbers
+*  (in exact arithmetic) but diagonal scaling will.  For further
+*  explanation of balancing, see section 4.10.2 of the LAPACK
+*  Users' Guide.
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Indicates how the input matrix should be diagonally scaled
+*          and/or permuted to improve the conditioning of its
+*          eigenvalues.
+*          = 'N': Do not diagonally scale or permute;
+*          = 'P': Perform permutations to make the matrix more nearly
+*                 upper triangular. Do not diagonally scale;
+*          = 'S': Diagonally scale the matrix, ie. replace A by
+*                 D*A*D**(-1), where D is a diagonal matrix chosen
+*                 to make the rows and columns of A more equal in
+*                 norm. Do not permute;
+*          = 'B': Both diagonally scale and permute A.
+*
+*          Computed reciprocal condition numbers will be for the matrix
+*          after balancing and/or permuting. Permuting does not change
+*          condition numbers (in exact arithmetic), but balancing does.
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N': left eigenvectors of A are not computed;
+*          = 'V': left eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVL must = 'V'.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N': right eigenvectors of A are not computed;
+*          = 'V': right eigenvectors of A are computed.
+*          If SENSE = 'E' or 'B', JOBVR must = 'V'.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': None are computed;
+*          = 'E': Computed for eigenvalues only;
+*          = 'V': Computed for right eigenvectors only;
+*          = 'B': Computed for eigenvalues and right eigenvectors.
+*
+*          If SENSE = 'E' or 'B', both left and right eigenvectors
+*          must also be computed (JOBVL = 'V' and JOBVR = 'V').
+*
+*  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.  If JOBVL = 'V' or
+*          JOBVR = 'V', A contains the Schur form of the balanced
+*          version of the matrix A.
+*
+*  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.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values determined when A was
+*          balanced.  The balanced A(i,j) = 0 if I > J and
+*          J = 1,...,ILO-1 or I = IHI+1,...,N.
+*
+*  SCALE   (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          when balancing A.  If P(j) is the index of the row and column
+*          interchanged with row and column j, and D(j) is the scaling
+*          factor applied to row and column j, then
+*          SCALE(J) = P(J),    for J = 1,...,ILO-1
+*                   = D(J),    for J = ILO,...,IHI
+*                   = P(J)     for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) DOUBLE PRECISION
+*          The one-norm of the balanced matrix (the maximum
+*          of the sum of absolute values of elements of any column).
+*
+*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)
+*          RCONDE(j) is the reciprocal condition number of the j-th
+*          eigenvalue.
+*
+*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)
+*          RCONDV(j) is the reciprocal condition number of the j-th
+*          right eigenvector.
+*
+*  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 SENSE = 'N' or 'E',
+*          LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
+*          LWORK >= N*N+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 or condition numbers
+*                have been computed; elements 1:ILO-1 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, WNTSNB, WNTSNE,
+     $                   WNTSNN, WNTSNV
+      CHARACTER          JOB, SIDE
+      INTEGER            HSWORK, I, ICOND, IERR, 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, DLASCL, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL,
+     $                   ZGEHRD, ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC,
+     $                   ZTRSNA, 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' )
+      WNTSNN = LSAME( SENSE, 'N' )
+      WNTSNE = LSAME( SENSE, 'E' )
+      WNTSNV = LSAME( SENSE, 'V' )
+      WNTSNB = LSAME( SENSE, 'B' )
+      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) .OR.
+     $    LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
+     $         ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
+     $         WANTVR ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -12
+      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 )
+*
+            IF( WANTVL ) THEN
+               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
+     $                WORK, -1, INFO )
+            ELSE IF( WANTVR ) THEN
+               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+            ELSE
+               IF( WNTSNN ) THEN
+                  CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+               ELSE
+                  CALL ZHSEQR( 'S', 'N', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+               END IF
+            END IF
+            HSWORK = WORK( 1 )
+*
+            IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+               MINWRK = 2*N
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MINWRK = MAX( MINWRK, N*N + 2*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MAXWRK = MAX( MAXWRK, N*N + 2*N )
+            ELSE
+               MINWRK = 2*N
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MINWRK = MAX( MINWRK, N*N + 2*N )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               IF( .NOT.( WNTSNN .OR. WNTSNE ) )
+     $            MAXWRK = MAX( MAXWRK, N*N + 2*N )
+               MAXWRK = MAX( MAXWRK, 2*N )
+            END IF
+            MAXWRK = MAX( MAXWRK, MINWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ICOND = 0
+      ANRM = 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 and compute ABNRM
+*
+      CALL ZGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
+      ABNRM = ZLANGE( '1', N, N, A, LDA, DUM )
+      IF( SCALEA ) THEN
+         DUM( 1 ) = ABNRM
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+         ABNRM = DUM( 1 )
+      END IF
+*
+*     Reduce to upper Hessenberg form
+*     (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
+*        If condition numbers desired, compute Schur form
+*
+         IF( WNTSNN ) THEN
+            JOB = 'E'
+         ELSE
+            JOB = 'S'
+         END IF
+*
+*        (CWorkspace: need 1, prefer HSWORK (see comments) )
+*        (RWorkspace: none)
+*
+         IWRK = ITAU
+         CALL ZHSEQR( JOB, '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 N)
+*
+         CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                N, NOUT, WORK( IWRK ), RWORK, IERR )
+      END IF
+*
+*     Compute condition numbers if desired
+*     (CWorkspace: need N*N+2*N unless SENSE = 'E')
+*     (RWorkspace: need 2*N unless SENSE = 'E')
+*
+      IF( .NOT.WNTSNN ) THEN
+         CALL ZTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, RWORK,
+     $                ICOND )
+      END IF
+*
+      IF( WANTVL ) THEN
+*
+*        Undo balancing of left eigenvectors
+*
+         CALL ZGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, 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( K ) = DBLE( VL( K, I ) )**2 +
+     $                      DIMAG( VL( K, I ) )**2
+   10       CONTINUE
+            K = IDAMAX( N, RWORK, 1 )
+            TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( K ) )
+            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
+*
+         CALL ZGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, 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( K ) = DBLE( VR( K, I ) )**2 +
+     $                      DIMAG( VR( K, I ) )**2
+   30       CONTINUE
+            K = IDAMAX( N, RWORK, 1 )
+            TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( K ) )
+            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.EQ.0 ) THEN
+            IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
+     $         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
+     $                      IERR )
+         ELSE
+            CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of ZGEEVX
+*
+      END
diff --git a/SRC/zgegs.f b/SRC/zgegs.f
new file mode 100644
index 00000000..c6b30c73
--- /dev/null
+++ b/SRC/zgegs.f
@@ -0,0 +1,428 @@
+      SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA,
+     $                  VSL, LDVSL, VSR, LDVSR, 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          JOBVSL, JOBVSR
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine ZGGES.
+*
+*  ZGEGS computes the eigenvalues, Schur form, and, optionally, the
+*  left and or/right Schur vectors of a complex matrix pair (A,B).
+*  Given two square matrices A and B, the generalized Schur
+*  factorization has the form
+*  
+*     A = Q*S*Z**H,  B = Q*T*Z**H
+*  
+*  where Q and Z are unitary matrices and S and T are upper triangular.
+*  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
+*  ZGEGV should be used instead.  See ZGEGV 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) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the matrix A.
+*          On exit, the upper triangular matrix S from the generalized
+*          Schur factorization.
+*
+*  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.
+*          On exit, the upper triangular matrix T from the generalized
+*          Schur factorization.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX*16 array, dimension (N)
+*          The complex scalars alpha that define the eigenvalues of
+*          GNEP.  ALPHA(j) = S(j,j), the diagonal element of the Schur
+*          form of A.
+*
+*  BETA    (output) COMPLEX*16 array, dimension (N)
+*          The non-negative real scalars beta that define the
+*          eigenvalues of GNEP.  BETA(j) = T(j,j), the diagonal element
+*          of the triangular factor T.
+*
+*          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.
+*
+*
+*  VSL     (output) COMPLEX*16 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) COMPLEX*16 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) 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.
+*          To compute the optimal value of LWORK, call ILAENV to get
+*          blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;
+*          the optimal LWORK is 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.
+*
+*  RWORK   (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.
+*          =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:  errors that usually indicate LAPACK problems:
+*                =N+1: error return from ZGGBAL
+*                =N+2: error return from ZGEQRF
+*                =N+3: error return from ZUNMQR
+*                =N+4: error return from ZUNGQR
+*                =N+5: error return from ZGGHRD
+*                =N+6: error return from ZHGEQZ (other than failed
+*                                               iteration)
+*                =N+7: error return from ZGGBAK (computing VSL)
+*                =N+8: error return from ZGGBAK (computing VSR)
+*                =N+9: error return from ZLASCL (various places)
+*
+*  =====================================================================
+*
+*     .. 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, ILVSL, ILVSR, LQUERY
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IRIGHT, IROWS, IRWORK, ITAU, IWORK, LOPT,
+     $                   LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SAFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ,
+     $                   ZLACPY, ZLASCL, ZLASET, ZUNGQR, ZUNMQR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. 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( 2*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 = -11
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -15
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB1 = ILAENV( 1, 'ZGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'ZUNMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'ZUNGQR', ' ', N, N, N, -1 )
+         NB = MAX( NB1, NB2, NB3 )
+         LOPT = N*( NB+1 )
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEGS ', -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 = 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 ) THEN
+         CALL ZLASCL( '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 = 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 ) THEN
+         CALL ZLASCL( '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
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IRWORK = IRIGHT + N
+      IWORK = 1
+      CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
+     $             RWORK( IRIGHT ), RWORK( IRWORK ), 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
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = IWORK
+      IWORK = ITAU + IROWS
+      CALL ZGEQRF( 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 ZUNMQR( 'L', 'C', 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 ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
+         CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VSL( ILO+1, ILO ), LDVSL )
+         CALL ZUNGQR( 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 ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      CALL ZGGHRD( 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
+*
+      IWORK = ITAU
+      CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWORK ),
+     $             LWORK+1-IWORK, RWORK( IRWORK ), 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 ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSL, LDVSL, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 10
+         END IF
+      END IF
+      IF( ILVSR ) THEN
+         CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( 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 ZLASCL( 'U', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL ZLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHA, N, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL ZLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL ZLASCL( '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 ZGEGS
+*
+      END
diff --git a/SRC/zgegv.f b/SRC/zgegv.f
new file mode 100644
index 00000000..fdc3bded
--- /dev/null
+++ b/SRC/zgegv.f
@@ -0,0 +1,601 @@
+      SUBROUTINE ZGEGV( 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
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine ZGGEV.
+*
+*  ZGEGV computes the eigenvalues and, optionally, the left and/or right
+*  eigenvectors of a complex matrix pair (A,B).
+*  Given two square matrices A and B,
+*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
+*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such
+*  that
+*     A*x = lambda*B*x.
+*
+*  An alternate form is to find the eigenvalues mu and corresponding
+*  eigenvectors y such that
+*     mu*A*y = B*y.
+*
+*  These two forms are equivalent with mu = 1/lambda and x = y if
+*  neither lambda nor mu is zero.  In order to deal with the case that
+*  lambda or mu is zero or small, two values alpha and beta are returned
+*  for each eigenvalue, such that lambda = alpha/beta and
+*  mu = beta/alpha.
+*
+*  The vectors x and y in the above equations are right eigenvectors of
+*  the matrix pair (A,B).  Vectors u and v satisfying
+*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B
+*  are left eigenvectors of (A,B).
+*
+*  Note: this routine performs "full balancing" on A and B -- see
+*  "Further Details", below.
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N':  do not compute the left generalized eigenvectors;
+*          = 'V':  compute the left generalized eigenvectors (returned
+*                  in VL).
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N':  do not compute the right generalized eigenvectors;
+*          = 'V':  compute the right generalized eigenvectors (returned
+*                  in VR).
+*
+*  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.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit A
+*          contains the Schur form of A from the generalized Schur
+*          factorization of the pair (A,B) after balancing.  If no
+*          eigenvectors were computed, then only the diagonal elements
+*          of the Schur form will be correct.  See ZGGHRD and ZHGEQZ
+*          for details.
+*
+*  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.
+*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
+*          upper triangular matrix obtained from B in the generalized
+*          Schur factorization of the pair (A,B) after balancing.
+*          If no eigenvectors were computed, then only the diagonal
+*          elements of B will be correct.  See ZGGHRD and ZHGEQZ for
+*          details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX*16 array, dimension (N)
+*          The complex scalars alpha that define the eigenvalues of
+*          GNEP.
+*
+*  BETA    (output) COMPLEX*16 array, dimension (N)
+*          The complex scalars beta that define the eigenvalues of GNEP.
+*          
+*          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.
+*
+*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored
+*          in the columns of VL, in the same order as their eigenvalues.
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvectors
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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 eigenvectors x(j) are stored
+*          in the columns of VR, in the same order as their eigenvalues.
+*          Each eigenvector is scaled so that its largest component has
+*          abs(real part) + abs(imag. part) = 1, except for eigenvectors
+*          corresponding to an eigenvalue with alpha = beta = 0, which
+*          are set to zero.
+*          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.
+*          To compute the optimal value of LWORK, call ILAENV to get
+*          blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR;
+*          The optimal LWORK is  MAX( 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.
+*
+*  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:  errors that usually indicate LAPACK problems:
+*                =N+1: error return from ZGGBAL
+*                =N+2: error return from ZGEQRF
+*                =N+3: error return from ZUNMQR
+*                =N+4: error return from ZUNGQR
+*                =N+5: error return from ZGGHRD
+*                =N+6: error return from ZHGEQZ (other than failed
+*                                               iteration)
+*                =N+7: error return from ZTGEVC
+*                =N+8: error return from ZGGBAK (computing VL)
+*                =N+9: error return from ZGGBAK (computing VR)
+*                =N+10: error return from ZLASCL (various calls)
+*
+*  Further Details
+*  ===============
+*
+*  Balancing
+*  ---------
+*
+*  This driver calls ZGGBAL to both permute and scale rows and columns
+*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
+*  and PL*B*R will be upper triangular except for the diagonal blocks
+*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
+*  possible.  The diagonal scaling matrices DL and DR are chosen so
+*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
+*  one (except for the elements that start out zero.)
+*
+*  After the eigenvalues and eigenvectors of the balanced matrices
+*  have been computed, ZGGBAK transforms the eigenvectors back to what
+*  they would have been (in perfect arithmetic) if they had not been
+*  balanced.
+*
+*  Contents of A and B on Exit
+*  -------- -- - --- - -- ----
+*
+*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
+*  both), then on exit the arrays A and B will contain the complex Schur
+*  form[*] of the "balanced" versions of A and B.  If no eigenvectors
+*  are computed, then only the diagonal blocks will be correct.
+*
+*  [*] In other words, upper triangular form.
+*
+*  =====================================================================
+*
+*     .. 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            ILIMIT, ILV, ILVL, ILVR, LQUERY
+      CHARACTER          CHTEMP
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IN, IRIGHT, IROWS, IRWORK, ITAU, IWORK, JC, JR,
+     $                   LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+      DOUBLE PRECISION   ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
+     $                   BNRM1, BNRM2, EPS, SAFMAX, SAFMIN, SALFAI,
+     $                   SALFAR, SBETA, SCALE, TEMP
+      COMPLEX*16         X
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           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, DCMPLX, DIMAG, INT, MAX
+*     ..
+*     .. 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
+*
+      LWKMIN = MAX( 2*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( 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
+      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -15
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB1 = ILAENV( 1, 'ZGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'ZUNMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'ZUNGQR', ' ', N, N, N, -1 )
+         NB = MAX( NB1, NB2, NB3 )
+         LOPT = MAX( 2*N, N*( NB+1 ) )
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEGV ', -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' )
+      SAFMIN = SAFMIN + SAFMIN
+      SAFMAX = ONE / SAFMIN
+*
+*     Scale A
+*
+      ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
+      ANRM1 = ANRM
+      ANRM2 = ONE
+      IF( ANRM.LT.ONE ) THEN
+         IF( SAFMAX*ANRM.LT.ONE ) THEN
+            ANRM1 = SAFMIN
+            ANRM2 = SAFMAX*ANRM
+         END IF
+      END IF
+*
+      IF( ANRM.GT.ZERO ) THEN
+         CALL ZLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Scale B
+*
+      BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
+      BNRM1 = BNRM
+      BNRM2 = ONE
+      IF( BNRM.LT.ONE ) THEN
+         IF( SAFMAX*BNRM.LT.ONE ) THEN
+            BNRM1 = SAFMIN
+            BNRM2 = SAFMAX*BNRM
+         END IF
+      END IF
+*
+      IF( BNRM.GT.ZERO ) THEN
+         CALL ZLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 10
+            RETURN
+         END IF
+      END IF
+*
+*     Permute the matrix to make it more nearly triangular
+*     Also "balance" the matrix.
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IRWORK = IRIGHT + N
+      CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
+     $             RWORK( IRIGHT ), RWORK( IRWORK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 1
+         GO TO 80
+      END IF
+*
+*     Reduce B to triangular form, and initialize VL and/or VR
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWORK = ITAU + IROWS
+      CALL ZGEQRF( 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 80
+      END IF
+*
+      CALL ZUNMQR( 'L', 'C', 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 80
+      END IF
+*
+      IF( ILVL ) THEN
+         CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
+         CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VL( ILO+1, ILO ), LDVL )
+         CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                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 80
+         END IF
+      END IF
+*
+      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, IINFO )
+      ELSE
+         CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
+      END IF
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 5
+         GO TO 80
+      END IF
+*
+*     Perform QZ algorithm
+*
+      IWORK = 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( IWORK ),
+     $             LWORK+1-IWORK, RWORK( IRWORK ), 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 80
+      END IF
+*
+      IF( ILV ) THEN
+*
+*        Compute Eigenvectors
+*
+         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( IWORK ), RWORK( IRWORK ),
+     $                IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 80
+         END IF
+*
+*        Undo balancing on VL and VR, rescale
+*
+         IF( ILVL ) THEN
+            CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                   RWORK( IRIGHT ), N, VL, LDVL, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 8
+               GO TO 80
+            END IF
+            DO 30 JC = 1, N
+               TEMP = ZERO
+               DO 10 JR = 1, N
+                  TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
+   10          CONTINUE
+               IF( TEMP.LT.SAFMIN )
+     $            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, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = N + 9
+               GO TO 80
+            END IF
+            DO 60 JC = 1, N
+               TEMP = ZERO
+               DO 40 JR = 1, N
+                  TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
+   40          CONTINUE
+               IF( TEMP.LT.SAFMIN )
+     $            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 of eigenvector calculation
+*
+      END IF
+*
+*     Undo scaling in alpha, beta
+*
+*     Note: this does not give the alpha and beta for the unscaled
+*     problem.
+*
+*     Un-scaling is limited to avoid underflow in alpha and beta
+*     if they are significant.
+*
+      DO 70 JC = 1, N
+         ABSAR = ABS( DBLE( ALPHA( JC ) ) )
+         ABSAI = ABS( DIMAG( ALPHA( JC ) ) )
+         ABSB = ABS( DBLE( BETA( JC ) ) )
+         SALFAR = ANRM*DBLE( ALPHA( JC ) )
+         SALFAI = ANRM*DIMAG( ALPHA( JC ) )
+         SBETA = BNRM*DBLE( BETA( JC ) )
+         ILIMIT = .FALSE.
+         SCALE = ONE
+*
+*        Check for significant underflow in imaginary part of ALPHA
+*
+         IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = ( SAFMIN / ANRM1 ) / MAX( SAFMIN, ANRM2*ABSAI )
+         END IF
+*
+*        Check for significant underflow in real part of ALPHA
+*
+         IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
+     $       MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( SAFMIN / ANRM1 ) /
+     $              MAX( SAFMIN, ANRM2*ABSAR ) )
+         END IF
+*
+*        Check for significant underflow in BETA
+*
+         IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
+     $       MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
+            ILIMIT = .TRUE.
+            SCALE = MAX( SCALE, ( SAFMIN / BNRM1 ) /
+     $              MAX( SAFMIN, BNRM2*ABSB ) )
+         END IF
+*
+*        Check for possible overflow when limiting scaling
+*
+         IF( ILIMIT ) THEN
+            TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
+     $             ABS( SBETA ) )
+            IF( TEMP.GT.ONE )
+     $         SCALE = SCALE / TEMP
+            IF( SCALE.LT.ONE )
+     $         ILIMIT = .FALSE.
+         END IF
+*
+*        Recompute un-scaled ALPHA, BETA if necessary.
+*
+         IF( ILIMIT ) THEN
+            SALFAR = ( SCALE*DBLE( ALPHA( JC ) ) )*ANRM
+            SALFAI = ( SCALE*DIMAG( ALPHA( JC ) ) )*ANRM
+            SBETA = ( SCALE*BETA( JC ) )*BNRM
+         END IF
+         ALPHA( JC ) = DCMPLX( SALFAR, SALFAI )
+         BETA( JC ) = SBETA
+   70 CONTINUE
+*
+   80 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZGEGV
+*
+      END
diff --git a/SRC/zgehd2.f b/SRC/zgehd2.f
new file mode 100644
index 00000000..c73f4200
--- /dev/null
+++ b/SRC/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/zgehrd.f b/SRC/zgehrd.f
new file mode 100644
index 00000000..83c1aa32
--- /dev/null
+++ b/SRC/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/zgelq2.f b/SRC/zgelq2.f
new file mode 100644
index 00000000..4c2368aa
--- /dev/null
+++ b/SRC/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, ZLARFP
+*     ..
+*     .. 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 ZLARFP( 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/zgelqf.f b/SRC/zgelqf.f
new file mode 100644
index 00000000..5dac50dc
--- /dev/null
+++ b/SRC/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/zgels.f b/SRC/zgels.f
new file mode 100644
index 00000000..96ff913e
--- /dev/null
+++ b/SRC/zgels.f
@@ -0,0 +1,423 @@
+      SUBROUTINE ZGELS( 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 ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELS solves overdetermined or underdetermined complex linear systems
+*  involving an M-by-N matrix A, or its conjugate-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 = 'C' and m >= n:  find the minimum norm solution of
+*     an undetermined system A**H * X = B.
+*
+*  4. If TRANS = 'C' and m < n:  find the least squares solution of
+*     an overdetermined system, i.e., solve the least squares problem
+*                  minimize || B - A**H * 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;
+*          = 'C': the linear system involves A**H.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*            if M >= N, A is overwritten by details of its QR
+*                       factorization as returned by ZGEQRF;
+*            if M <  N, A is overwritten by details of its LQ
+*                       factorization as returned by ZGELQF.
+*
+*  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 matrix B of right hand side vectors, stored
+*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+*          if TRANS = 'C'.
+*          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 the
+*          modulus 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 = 'C' and m >= n, rows 1 to M of B contain the
+*          minimum norm solution vectors;
+*          if TRANS = 'C' 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 the modulus 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) 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, 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.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. 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, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZGELQF, ZGEQRF, ZLASCL, ZLASET,
+     $                   ZTRTRS, ZUNMLQ, ZUNMQR
+*     ..
+*     .. 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, 'C' ) ) ) 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, 'ZGEQRF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LN', M, NRHS, N,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'ZUNMQR', 'LC', M, NRHS, N,
+     $              -1 ) )
+            END IF
+         ELSE
+            NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', 'LC', N, NRHS, M,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'ZUNMLQ', '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( 'ZGELS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         CALL ZLASET( 'Full', MAX( M, N ), NRHS, CZERO, CZERO, 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 = 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 )
+         GO TO 50
+      END IF
+*
+      BROW = M
+      IF( TPSD )
+     $   BROW = N
+      BNRM = ZLANGE( 'M', BROW, 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, BROW, 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, BROW, NRHS, B, LDB,
+     $                INFO )
+         IBSCL = 2
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        compute QR factorization of A
+*
+         CALL ZGEQRF( 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 ZUNMQR( 'Left', 'Conjugate 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 ZTRTRS( '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 ZTRTRS( 'Upper', 'Conjugate 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 ) = CZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+            CALL ZUNMQR( '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 ZGELQF( 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 ZTRTRS( '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 ) = CZERO
+   30          CONTINUE
+   40       CONTINUE
+*
+*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
+*
+            CALL ZUNMLQ( 'Left', 'Conjugate 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 ZUNMLQ( '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 ZTRTRS( 'Lower', 'Conjugate 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 ZLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+*
+   50 CONTINUE
+      WORK( 1 ) = DBLE( WSIZE )
+*
+      RETURN
+*
+*     End of ZGELS
+*
+      END
diff --git a/SRC/zgelsd.f b/SRC/zgelsd.f
new file mode 100644
index 00000000..e6d785e8
--- /dev/null
+++ b/SRC/zgelsd.f
@@ -0,0 +1,570 @@
+      SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+     $                   WORK, LWORK, RWORK, IWORK, 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            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), S( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELSD computes the minimum-norm solution to a real linear least
+*  squares problem:
+*      minimize 2-norm(| b - A*x |)
+*  using the singular value decomposition (SVD) of A. A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The problem is solved in three steps:
+*  (1) Reduce the coefficient matrix A to bidiagonal form with
+*      Householder tranformations, reducing the original problem
+*      into a "bidiagonal least squares problem" (BLS)
+*  (2) Solve the BLS using a divide and conquer approach.
+*  (3) Apply back all the Householder tranformations to solve
+*      the original least squares problem.
+*
+*  The effective rank of A is determined by treating as zero those
+*  singular values which are less than RCOND times the largest singular
+*  value.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been destroyed.
+*
+*  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, 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 the modulus of elements n+1:m in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,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) 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 must be at least 1.
+*          The exact minimum amount of workspace needed depends on M,
+*          N and NRHS. As long as LWORK is at least
+*              2*N + N*NRHS
+*          if M is greater than or equal to N or
+*              2*M + M*NRHS
+*          if M is less than N, the code will execute correctly.
+*          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 array WORK and the
+*          minimum sizes of the arrays RWORK and IWORK, and returns
+*          these values as the first entries of the WORK, RWORK and
+*          IWORK arrays, and no error message related to LWORK is issued
+*          by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*          LRWORK >=
+*              10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
+*             (SMLSIZ+1)**2
+*          if M is greater than or equal to N or
+*             10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
+*             (SMLSIZ+1)**2
+*          if M is less than N, the code will execute correctly.
+*          SMLSIZ is returned by ILAENV and is equal to the maximum
+*          size of the subproblems at the bottom of the computation
+*          tree (usually about 25), and
+*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+*          On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
+*          where MINMN = MIN( M,N ).
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
+     $                   LDWORK, LIWORK, LRWORK, MAXMN, MAXWRK, MINMN,
+     $                   MINWRK, MM, MNTHR, NLVL, NRWORK, NWORK, SMLSIZ
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, DLASCL, DLASET, XERBLA, ZGEBRD, ZGELQF,
+     $                   ZGEQRF, ZLACPY, ZLALSD, ZLASCL, ZLASET, ZUNMBR,
+     $                   ZUNMLQ, ZUNMQR
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, LOG, MAX, MIN, DBLE
+*     ..
+*     .. 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
+         LIWORK = 1
+         LRWORK = 1
+         IF( MINMN.GT.0 ) THEN
+            SMLSIZ = ILAENV( 9, 'ZGELSD', ' ', 0, 0, 0, 0 )
+            MNTHR = ILAENV( 6, 'ZGELSD', ' ', M, N, NRHS, -1 )
+            NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ + 1 ) ) /
+     $                  LOG( TWO ) ) + 1, 0 )
+            LIWORK = 3*MINMN*NLVL + 11*MINMN
+            MM = M
+            IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+*              Path 1a - overdetermined, with many more rows than
+*                        columns.
+*
+               MM = N
+               MAXWRK = MAX( MAXWRK, N*ILAENV( 1, 'ZGEQRF', ' ', M, N,
+     $                       -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, NRHS*ILAENV( 1, 'ZUNMQR', 'LC', M,
+     $                       NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined.
+*
+               LRWORK = 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
+     $                  ( SMLSIZ + 1 )**2
+               MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1,
+     $                       'ZGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR',
+     $                       'QLC', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'ZUNMBR', 'PLN', N, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + N*NRHS )
+               MINWRK = MAX( 2*N + MM, 2*N + N*NRHS )
+            END IF
+            IF( N.GT.M ) THEN
+               LRWORK = 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
+     $                  ( SMLSIZ + 1 )**2
+               IF( N.GE.MNTHR ) THEN
+*
+*                 Path 2a - underdetermined, with many more columns
+*                           than rows.
+*
+                  MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+     $                          'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+     $                          'ZUNMBR', 'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
+     $                          'ZUNMLQ', 'LC', N, NRHS, M, -1 ) )
+                  IF( NRHS.GT.1 ) THEN
+                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+                  ELSE
+                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
+                  END IF
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + M*NRHS )
+!     XXX: Ensure the Path 2a case below is triggered.  The workspace
+!     calculation should use queries for all routines eventually.
+                  MAXWRK = MAX( MAXWRK,
+     $                 4*M+M*M+MAX( M, 2*M-4, NRHS, N-3*M ) )
+               ELSE
+*
+*                 Path 2 - underdetermined.
+*
+                  MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR',
+     $                          'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNMBR',
+     $                          'PLN', N, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M + M*NRHS )
+               END IF
+               MINWRK = MAX( 2*M + N, 2*M + M*NRHS )
+            END IF
+         END IF
+         MINWRK = MIN( MINWRK, MAXWRK )
+         WORK( 1 ) = MAXWRK
+         IWORK( 1 ) = LIWORK
+         RWORK( 1 ) = LRWORK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELSD', -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 entry 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 )
+         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+         RANK = 0
+         GO TO 10
+      END IF
+*
+*     Scale B if max entry outside range [SMLNUM,BIGNUM].
+*
+      BNRM = 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
+*
+*     If M < N make sure B(M+1:N,:) = 0
+*
+      IF( M.LT.N )
+     $   CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
+*
+*     Overdetermined case.
+*
+      IF( M.GE.N ) THEN
+*
+*        Path 1 - overdetermined or exactly determined.
+*
+         MM = M
+         IF( M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns
+*
+            MM = N
+            ITAU = 1
+            NWORK = ITAU + N
+*
+*           Compute A=Q*R.
+*           (RWorkspace: need N)
+*           (CWorkspace: need N, prefer N*NB)
+*
+            CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                   LWORK-NWORK+1, INFO )
+*
+*           Multiply B by transpose(Q).
+*           (RWorkspace: need N)
+*           (CWorkspace: need NRHS, prefer NRHS*NB)
+*
+            CALL ZUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*           Zero out below R.
+*
+            IF( N.GT.1 ) THEN
+               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+            END IF
+         END IF
+*
+         ITAUQ = 1
+         ITAUP = ITAUQ + N
+         NWORK = ITAUP + N
+         IE = 1
+         NRWORK = IE + N
+*
+*        Bidiagonalize R in A.
+*        (RWorkspace: need N)
+*        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
+*
+         CALL ZGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R.
+*        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
+*
+         CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL ZLALSD( 'U', SMLSIZ, N, NRHS, S, RWORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
+     $                IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of R.
+*
+         CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+     $         MAX( M, 2*M-4, NRHS, N-3*M ) ) 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
+         NWORK = M + 1
+*
+*        Compute A=L*Q.
+*        (CWorkspace: need 2*M, prefer M+M*NB)
+*
+         CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+         IL = NWORK
+*
+*        Copy L to WORK(IL), zeroing out above its diagonal.
+*
+         CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         ITAUQ = IL + LDWORK*M
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+         IE = 1
+         NRWORK = IE + M
+*
+*        Bidiagonalize L in WORK(IL).
+*        (RWorkspace: need M)
+*        (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB)
+*
+         CALL ZGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L.
+*        (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUQ ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL ZLALSD( 'U', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
+     $                IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of L.
+*
+         CALL ZUNMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUP ), B, LDB, WORK( NWORK ),
+     $                LWORK-NWORK+1, INFO )
+*
+*        Zero out below first M rows of B.
+*
+         CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
+         NWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B.
+*        (CWorkspace: need NRHS, prefer NRHS*NB)
+*
+         CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases.
+*
+         ITAUQ = 1
+         ITAUP = ITAUQ + M
+         NWORK = ITAUP + M
+         IE = 1
+         NRWORK = IE + M
+*
+*        Bidiagonalize A.
+*        (RWorkspace: need M)
+*        (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
+*
+         CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors.
+*        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
+*
+         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+*        Solve the bidiagonal least squares problem.
+*
+         CALL ZLALSD( 'L', SMLSIZ, M, NRHS, S, RWORK( IE ), B, LDB,
+     $                RCOND, RANK, WORK( NWORK ), RWORK( NRWORK ),
+     $                IWORK, INFO )
+         IF( INFO.NE.0 ) THEN
+            GO TO 10
+         END IF
+*
+*        Multiply B by right bidiagonalizing vectors of A.
+*
+         CALL ZUNMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
+     $                B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+      END IF
+*
+*     Undo scaling.
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL ZLASCL( '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 ZLASCL( '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 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
+*
+   10 CONTINUE
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWORK
+      RWORK( 1 ) = LRWORK
+      RETURN
+*
+*     End of ZGELSD
+*
+      END
diff --git a/SRC/zgelss.f b/SRC/zgelss.f
new file mode 100644
index 00000000..7ea253ad
--- /dev/null
+++ b/SRC/zgelss.f
@@ -0,0 +1,634 @@
+      SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, 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 ..
+      DOUBLE PRECISION   RWORK( * ), S( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELSS computes the minimum norm solution to a complex 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) COMPLEX*16 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) COMPLEX*16 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 the modulus of elements n+1:m in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,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) 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, and also:
+*          LWORK >=  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.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))
+*
+*  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 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            BL, CHUNK, I, IASCL, IBSCL, IE, IL, IRWORK,
+     $                   ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
+     $                   MAXWRK, MINMN, MINWRK, MM, MNTHR
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         VDUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, DLASCL, DLASET, XERBLA, ZBDSQR, ZCOPY,
+     $                   ZDRSCL, ZGEBRD, ZGELQF, ZGEMM, ZGEMV, ZGEQRF,
+     $                   ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNMBR, ZUNMLQ,
+     $                   ZUNMQR
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. 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.
+*       CWorkspace refers to complex workspace, and RWorkspace refers
+*       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( MINMN.GT.0 ) THEN
+            MM = M
+            MNTHR = ILAENV( 6, 'ZGELSS', ' ', 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, 'ZGEQRF', ' ', M,
+     $                       N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'ZUNMQR', 'LC',
+     $                       M, NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined
+*
+               MAXWRK = MAX( MAXWRK, 2*N + ( MM + N )*ILAENV( 1,
+     $                       'ZGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + NRHS*ILAENV( 1, 'ZUNMBR',
+     $                       'QLC', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'ZUNGBR', 'P', N, N, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, N*NRHS )
+               MINWRK = 2*N + MAX( NRHS, M )
+            END IF
+            IF( N.GT.M ) THEN
+               MINWRK = 2*M + MAX( NRHS, N )
+               IF( N.GE.MNTHR ) THEN
+*
+*                 Path 2a - underdetermined, with many more columns
+*                 than rows
+*
+                  MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*M + 2*M*ILAENV( 1,
+     $                          'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*M + NRHS*ILAENV( 1,
+     $                          'ZUNMBR', 'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*M + ( M - 1 )*ILAENV( 1,
+     $                          'ZUNGBR', 'P', M, M, M, -1 ) )
+                  IF( NRHS.GT.1 ) THEN
+                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+                  ELSE
+                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
+                  END IF
+                  MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'ZUNMLQ',
+     $                          'LC', N, NRHS, M, -1 ) )
+               ELSE
+*
+*                 Path 2 - underdetermined
+*
+                  MAXWRK = 2*M + ( N + M )*ILAENV( 1, 'ZGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M + NRHS*ILAENV( 1, 'ZUNMBR',
+     $                          'QLC', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M + M*ILAENV( 1, 'ZUNGBR',
+     $                          'P', M, N, M, -1 ) )
+                  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( 'ZGELSS', -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 = 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 )
+         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, MINMN )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = 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
+*
+*     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
+*           (CWorkspace: need 2*N, prefer N+N*NB)
+*           (RWorkspace: none)
+*
+            CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                   LWORK-IWORK+1, INFO )
+*
+*           Multiply B by transpose(Q)
+*           (CWorkspace: need N+NRHS, prefer N+NRHS*NB)
+*           (RWorkspace: none)
+*
+            CALL ZUNMQR( 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*           Zero out below R
+*
+            IF( N.GT.1 )
+     $         CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+         END IF
+*
+         IE = 1
+         ITAUQ = 1
+         ITAUP = ITAUQ + N
+         IWORK = ITAUP + N
+*
+*        Bidiagonalize R in A
+*        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
+*        (RWorkspace: need N)
+*
+         CALL ZGEBRD( MM, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R
+*        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNMBR( 'Q', 'L', 'C', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors of R in A
+*        (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IRWORK = IE + N
+*
+*        Perform bidiagonal QR iteration
+*          multiply B by transpose of left singular vectors
+*          compute right singular vectors in A
+*        (CWorkspace: none)
+*        (RWorkspace: need BDSPAC)
+*
+         CALL ZBDSQR( 'U', N, N, 0, NRHS, S, RWORK( IE ), A, LDA, VDUM,
+     $                1, B, LDB, RWORK( IRWORK ), 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 ZDRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL ZLASET( 'F', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            END IF
+   10    CONTINUE
+*
+*        Multiply B by right singular vectors
+*        (CWorkspace: need N, prefer N*NRHS)
+*        (RWorkspace: none)
+*
+         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+            CALL ZGEMM( 'C', 'N', N, NRHS, N, CONE, A, LDA, B, LDB,
+     $                  CZERO, WORK, LDB )
+            CALL ZLACPY( '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 ZGEMM( 'C', 'N', N, BL, N, CONE, A, LDA, B( 1, I ),
+     $                     LDB, CZERO, WORK, N )
+               CALL ZLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
+   20       CONTINUE
+         ELSE
+            CALL ZGEMV( 'C', N, N, CONE, A, LDA, B, 1, CZERO, WORK, 1 )
+            CALL ZCOPY( N, WORK, 1, B, 1 )
+         END IF
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.3*M+M*M+MAX( M, NRHS, N-2*M ) )
+     $          THEN
+*
+*        Underdetermined case, M much less than N
+*
+*        Path 2a - underdetermined, with many more columns than rows
+*        and sufficient workspace for an efficient algorithm
+*
+         LDWORK = M
+         IF( LWORK.GE.3*M+M*LDA+MAX( M, NRHS, N-2*M ) )
+     $      LDWORK = LDA
+         ITAU = 1
+         IWORK = M + 1
+*
+*        Compute A=L*Q
+*        (CWorkspace: need 2*M, prefer M+M*NB)
+*        (RWorkspace: none)
+*
+         CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+         IL = IWORK
+*
+*        Copy L to WORK(IL), zeroing out above it
+*
+         CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         IE = 1
+         ITAUQ = IL + LDWORK*M
+         ITAUP = ITAUQ + M
+         IWORK = ITAUP + M
+*
+*        Bidiagonalize L in WORK(IL)
+*        (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*        (RWorkspace: need M)
+*
+         CALL ZGEBRD( M, M, WORK( IL ), LDWORK, S, RWORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L
+*        (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNMBR( 'Q', 'L', 'C', 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)
+*        (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IRWORK = IE + M
+*
+*        Perform bidiagonal QR iteration, computing right singular
+*        vectors of L in WORK(IL) and multiplying B by transpose of
+*        left singular vectors
+*        (CWorkspace: need M*M)
+*        (RWorkspace: need BDSPAC)
+*
+         CALL ZBDSQR( 'U', M, M, 0, NRHS, S, RWORK( IE ), WORK( IL ),
+     $                LDWORK, A, LDA, B, LDB, RWORK( IRWORK ), 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 ZDRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL ZLASET( 'F', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            END IF
+   30    CONTINUE
+         IWORK = IL + M*LDWORK
+*
+*        Multiply B by right singular vectors of L in WORK(IL)
+*        (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS)
+*        (RWorkspace: none)
+*
+         IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
+            CALL ZGEMM( 'C', 'N', M, NRHS, M, CONE, WORK( IL ), LDWORK,
+     $                  B, LDB, CZERO, WORK( IWORK ), LDB )
+            CALL ZLACPY( '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 ZGEMM( 'C', 'N', M, BL, M, CONE, WORK( IL ), LDWORK,
+     $                     B( 1, I ), LDB, CZERO, WORK( IWORK ), M )
+               CALL ZLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
+     $                      LDB )
+   40       CONTINUE
+         ELSE
+            CALL ZGEMV( 'C', M, M, CONE, WORK( IL ), LDWORK, B( 1, 1 ),
+     $                  1, CZERO, WORK( IWORK ), 1 )
+            CALL ZCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
+         END IF
+*
+*        Zero out below first M rows of B
+*
+         CALL ZLASET( 'F', N-M, NRHS, CZERO, CZERO, B( M+1, 1 ), LDB )
+         IWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B
+*        (CWorkspace: need M+NRHS, prefer M+NHRS*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNMLQ( 'L', 'C', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases
+*
+         IE = 1
+         ITAUQ = 1
+         ITAUP = ITAUQ + M
+         IWORK = ITAUP + M
+*
+*        Bidiagonalize A
+*        (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB)
+*        (RWorkspace: need N)
+*
+         CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors
+*        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNMBR( 'Q', 'L', 'C', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors in A
+*        (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IRWORK = IE + M
+*
+*        Perform bidiagonal QR iteration,
+*           computing right singular vectors of A in A and
+*           multiplying B by transpose of left singular vectors
+*        (CWorkspace: none)
+*        (RWorkspace: need BDSPAC)
+*
+         CALL ZBDSQR( 'L', M, N, 0, NRHS, S, RWORK( IE ), A, LDA, VDUM,
+     $                1, B, LDB, RWORK( IRWORK ), 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 ZDRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL ZLASET( 'F', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            END IF
+   50    CONTINUE
+*
+*        Multiply B by right singular vectors of A
+*        (CWorkspace: need N, prefer N*NRHS)
+*        (RWorkspace: none)
+*
+         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+            CALL ZGEMM( 'C', 'N', N, NRHS, M, CONE, A, LDA, B, LDB,
+     $                  CZERO, WORK, LDB )
+            CALL ZLACPY( 'G', 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 ZGEMM( 'C', 'N', N, BL, M, CONE, A, LDA, B( 1, I ),
+     $                     LDB, CZERO, WORK, N )
+               CALL ZLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
+   60       CONTINUE
+         ELSE
+            CALL ZGEMV( 'C', M, N, CONE, A, LDA, B, 1, CZERO, WORK, 1 )
+            CALL ZCOPY( N, WORK, 1, B, 1 )
+         END IF
+      END IF
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL ZLASCL( '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 ZLASCL( '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 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 ) = MAXWRK
+      RETURN
+*
+*     End of ZGELSS
+*
+      END
diff --git a/SRC/zgelsx.f b/SRC/zgelsx.f
new file mode 100644
index 00000000..d4d9130c
--- /dev/null
+++ b/SRC/zgelsx.f
@@ -0,0 +1,357 @@
+      SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+     $                   WORK, 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, M, N, NRHS, RANK
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine ZGELSY.
+*
+*  ZGELSX 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.
+*
+*  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.
+*          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) COMPLEX*16 array, dimension
+*                      (min(M,N) + max( N, 2*min(M,N)+NRHS )),
+*
+*  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 ..
+      INTEGER            IMAX, IMIN
+      PARAMETER          ( IMAX = 1, IMIN = 2 )
+      DOUBLE PRECISION   ZERO, ONE, DONE, NTDONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, DONE = ZERO,
+     $                   NTDONE = ONE )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
+     $                   SMLNUM
+      COMPLEX*16         C1, C2, S1, S2, T1, T2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQPF, ZLAIC1, ZLASCL, ZLASET, ZLATZM,
+     $                   ZTRSM, ZTZRQF, ZUNM2R
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCONJG, 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( 'ZGELSX', -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 = 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 100
+      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 ZGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), RWORK,
+     $             INFO )
+*
+*     complex workspace MN+N. 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 100
+      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
+*
+*     Logically partition R = [ R11 R12 ]
+*                             [  0  R22 ]
+*     where R11 = R(1:RANK,1:RANK)
+*
+*     [R11,R12] = [ T11, 0 ] * Y
+*
+      IF( RANK.LT.N )
+     $   CALL ZTZRQF( 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 ZUNM2R( 'Left', 'Conjugate 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 ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+     $            NRHS, CONE, A, LDA, B, LDB )
+*
+      DO 40 I = RANK + 1, N
+         DO 30 J = 1, NRHS
+            B( I, J ) = CZERO
+   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 ZLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
+     $                   DCONJG( 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 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
+*
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of ZGELSX
+*
+      END
diff --git a/SRC/zgelsy.f b/SRC/zgelsy.f
new file mode 100644
index 00000000..684cf2c2
--- /dev/null
+++ b/SRC/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/zgeql2.f b/SRC/zgeql2.f
new file mode 100644
index 00000000..33035883
--- /dev/null
+++ b/SRC/zgeql2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE ZGEQL2( 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
+*  =======
+*
+*  ZGEQL2 computes a QL factorization of a complex 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) COMPLEX*16 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
+*          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(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(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 ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF, ZLARFP
+*     ..
+*     .. 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( 'ZGEQL2', -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)
+*
+         ALPHA = A( M-K+I, N-K+I )
+         CALL ZLARFP( M-K+I, ALPHA, 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
+*
+         A( M-K+I, N-K+I ) = ONE
+         CALL ZLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1,
+     $               DCONJG( TAU( I ) ), A, LDA, WORK )
+         A( M-K+I, N-K+I ) = ALPHA
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGEQL2
+*
+      END
diff --git a/SRC/zgeqlf.f b/SRC/zgeqlf.f
new file mode 100644
index 00000000..d28bdc67
--- /dev/null
+++ b/SRC/zgeqlf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE ZGEQLF( 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
+*  =======
+*
+*  ZGEQLF computes a QL factorization of a complex 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) COMPLEX*16 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
+*          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,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 complex scalar, and v is a complex 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           XERBLA, ZGEQL2, ZLARFB, ZLARFT
+*     ..
+*     .. 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, 'ZGEQLF', ' ', 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( 'ZGEQLF', -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, 'ZGEQLF', ' ', 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, 'ZGEQLF', ' ', 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 ZGEQL2( 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 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', 'Conjugate 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 ZGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGEQLF
+*
+      END
diff --git a/SRC/zgeqp3.f b/SRC/zgeqp3.f
new file mode 100644
index 00000000..32bf3367
--- /dev/null
+++ b/SRC/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/zgeqpf.f b/SRC/zgeqpf.f
new file mode 100644
index 00000000..19b4966c
--- /dev/null
+++ b/SRC/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, ZLARFP, 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 ZLARFP( 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/zgeqr2.f b/SRC/zgeqr2.f
new file mode 100644
index 00000000..215eab79
--- /dev/null
+++ b/SRC/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, ZLARFP
+*     ..
+*     .. 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 ZLARFP( 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/zgeqrf.f b/SRC/zgeqrf.f
new file mode 100644
index 00000000..d11c9245
--- /dev/null
+++ b/SRC/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/zgerfs.f b/SRC/zgerfs.f
new file mode 100644
index 00000000..8b85fe65
--- /dev/null
+++ b/SRC/zgerfs.f
@@ -0,0 +1,345 @@
+      SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, 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          TRANS
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGERFS 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)
+*
+*  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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDAF,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by ZGETRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= 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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZGETRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGEMV, ZGETRS, ZLACN2
+*     ..
+*     .. 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
+      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( 'ZGERFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         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 ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK,
+     $               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
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               DO 60 I = 1, N
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 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 ZLACN2 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( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL ZGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK, N,
+     $                      INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZGETRS( TRANSN, N, 1, AF, LDAF, IPIV, WORK, N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZGERFS
+*
+      END
diff --git a/SRC/zgerq2.f b/SRC/zgerq2.f
new file mode 100644
index 00000000..4d69c240
--- /dev/null
+++ b/SRC/zgerq2.f
@@ -0,0 +1,123 @@
+      SUBROUTINE ZGERQ2( 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
+*  =======
+*
+*  ZGERQ2 computes an RQ factorization of a complex 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) COMPLEX*16 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 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(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(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(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 ..
+      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, ZLARFP
+*     ..
+*     .. 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( 'ZGERQ2', -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 ZLACGV( N-K+I, A( M-K+I, 1 ), LDA )
+         ALPHA = A( M-K+I, N-K+I )
+         CALL ZLARFP( N-K+I, ALPHA, 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
+*
+         A( M-K+I, N-K+I ) = ONE
+         CALL ZLARF( '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 ) = ALPHA
+         CALL ZLACGV( N-K+I-1, A( M-K+I, 1 ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGERQ2
+*
+      END
diff --git a/SRC/zgerqf.f b/SRC/zgerqf.f
new file mode 100644
index 00000000..4e249f1e
--- /dev/null
+++ b/SRC/zgerqf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE ZGERQF( 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
+*  =======
+*
+*  ZGERQF computes an RQ factorization of a complex 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) COMPLEX*16 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
+*          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,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 complex scalar, and v is a complex vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(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           XERBLA, ZGERQ2, ZLARFB, ZLARFT
+*     ..
+*     .. 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, '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( 'ZGERQF', -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, 'ZGERQF', ' ', 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, 'ZGERQF', ' ', 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 ZGERQ2( 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 ZLARFT( '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 ZLARFB( '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 ZGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGERQF
+*
+      END
diff --git a/SRC/zgesc2.f b/SRC/zgesc2.f
new file mode 100644
index 00000000..d4d51337
--- /dev/null
+++ b/SRC/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/zgesdd.f b/SRC/zgesdd.f
new file mode 100644
index 00000000..f717080f
--- /dev/null
+++ b/SRC/zgesdd.f
@@ -0,0 +1,1962 @@
+      SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
+     $                   LWORK, RWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*     8-15-00:  Improve consistency of WS calculations (eca)
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ
+      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), S( * )
+      COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGESDD computes the singular value decomposition (SVD) of a complex
+*  M-by-N matrix A, optionally computing the left and/or right singular
+*  vectors, by using divide-and-conquer method. 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 VT = V**H, not V.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix U:
+*          = 'A':  all M columns of U and all N rows of V**H are
+*                  returned in the arrays U and VT;
+*          = 'S':  the first min(M,N) columns of U and the first
+*                  min(M,N) rows of V**H are returned in the arrays U
+*                  and VT;
+*          = 'O':  If M >= N, the first N columns of U are overwritten
+*                  in the array A and all rows of V**H are returned in
+*                  the array VT;
+*                  otherwise, all columns of U are returned in the
+*                  array U and the first M rows of V**H are overwritten
+*                  in the array A;
+*          = 'N':  no columns of U or rows of V**H are computed.
+*
+*  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 JOBZ = 'O',  A is overwritten with the first N columns
+*                          of U (the left singular vectors, stored
+*                          columnwise) if M >= N;
+*                          A is overwritten with the first M rows
+*                          of V**H (the right singular vectors, stored
+*                          rowwise) otherwise.
+*          if JOBZ .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)
+*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
+*          UCOL = min(M,N) if JOBZ = 'S'.
+*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
+*          unitary matrix U;
+*          if JOBZ = 'S', U contains the first min(M,N) columns of U
+*          (the left singular vectors, stored columnwise);
+*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1; if
+*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
+*
+*  VT      (output) COMPLEX*16 array, dimension (LDVT,N)
+*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
+*          N-by-N unitary matrix V**H;
+*          if JOBZ = 'S', VT contains the first min(M,N) rows of
+*          V**H (the right singular vectors, stored rowwise);
+*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1; if
+*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
+*          if JOBZ = 'S', LDVT >= min(M,N).
+*
+*  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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).
+*          if JOBZ = 'O',
+*                LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
+*          if JOBZ = 'S' or 'A',
+*                LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, a workspace query is assumed.  The optimal
+*          size for the WORK array is calculated and stored in WORK(1),
+*          and no other work except argument checking is performed.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*          If JOBZ = 'N', LRWORK >= 5*min(M,N).
+*          Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 7*min(M,N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The updating process of DBDSDC did not converge.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            LQUERV
+      PARAMETER          ( LQUERV = -1 )
+      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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
+      INTEGER            BLK, CHUNK, I, IE, IERR, IL, IR, IRU, IRVT,
+     $                   ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
+     $                   LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
+     $                   MNTHR1, MNTHR2, NRWORK, NWORK, WRKBL
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSDC, DLASCL, XERBLA, ZGEBRD, ZGELQF, ZGEMM,
+     $                   ZGEQRF, ZLACP2, ZLACPY, ZLACRM, ZLARCM, ZLASCL,
+     $                   ZLASET, ZUNGBR, ZUNGLQ, ZUNGQR, ZUNMBR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      MNTHR1 = INT( MINMN*17.0D0 / 9.0D0 )
+      MNTHR2 = INT( MINMN*5.0D0 / 3.0D0 )
+      WNTQA = LSAME( JOBZ, 'A' )
+      WNTQS = LSAME( JOBZ, 'S' )
+      WNTQAS = WNTQA .OR. WNTQS
+      WNTQO = LSAME( JOBZ, 'O' )
+      WNTQN = LSAME( JOBZ, 'N' )
+      MINWRK = 1
+      MAXWRK = 1
+*
+      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
+     $         ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
+         INFO = -8
+      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
+     $         ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
+     $         ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
+         INFO = -10
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace 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 .AND. M.GT.0 .AND. N.GT.0 ) THEN
+         IF( M.GE.N ) THEN
+*
+*           There is no complex work space needed for bidiagonal SVD
+*           The real work space needed for bidiagonal SVD is BDSPAC
+*           for computing singular values and singular vectors; BDSPAN
+*           for computing singular values only.
+*           BDSPAC = 5*N*N + 7*N
+*           BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8))
+*
+            IF( M.GE.MNTHR1 ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1 (M much larger than N, JOBZ='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 ) )
+                  MINWRK = 3*N
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2 (M much larger than N, JOBZ='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, 'ZUNMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = M*N + N*N + WRKBL
+                  MINWRK = 2*N*N + 3*N
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3 (M much larger than N, JOBZ='S')
+*
+                  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, 'ZUNMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = N*N + 3*N
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4 (M much larger than N, JOBZ='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, 'ZUNMBR', 'QLN', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = N*N + 2*N + M
+               END IF
+            ELSE IF( M.GE.MNTHR2 ) THEN
+*
+*              Path 5 (M much larger than N, but not as much as MNTHR1)
+*
+               MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*N + M
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + N*N
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
+               END IF
+            ELSE
+*
+*              Path 6 (M at least N, but not much larger)
+*
+               MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*N + M
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNMBR', 'QLN', M, N, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + N*N
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNMBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNMBR', 'QLN', M, N, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'PRC', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*N+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) )
+               END IF
+            END IF
+         ELSE
+*
+*           There is no complex work space needed for bidiagonal SVD
+*           The real work space needed for bidiagonal SVD is BDSPAC
+*           for computing singular values and singular vectors; BDSPAN
+*           for computing singular values only.
+*           BDSPAC = 5*M*M + 7*M
+*           BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8))
+*
+            IF( N.GE.MNTHR1 ) THEN
+               IF( WNTQN ) THEN
+*
+*                 Path 1t (N much larger than M, JOBZ='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 ) )
+                  MINWRK = 3*M
+               ELSE IF( WNTQO ) THEN
+*
+*                 Path 2t (N much larger than M, JOBZ='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*
+     $                    ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) )
+                  MAXWRK = M*N + M*M + WRKBL
+                  MINWRK = 2*M*M + 3*M
+               ELSE IF( WNTQS ) THEN
+*
+*                 Path 3t (N much larger than M, JOBZ='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*
+     $                    ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = M*M + 3*M
+               ELSE IF( WNTQA ) THEN
+*
+*                 Path 4t (N much larger than M, JOBZ='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*
+     $                    ILAENV( 1, 'ZUNMBR', 'PRC', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNMBR', 'QLN', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = M*M + 2*M + N
+               END IF
+            ELSE IF( N.GE.MNTHR2 ) THEN
+*
+*              Path 5t (N much larger than M, but not as much as MNTHR1)
+*
+               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*M + N
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + M*M
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
+               END IF
+            ELSE
+*
+*              Path 6t (N greater than M, but not much larger)
+*
+               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MINWRK = 2*M + N
+               IF( WNTQO ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNMBR', 'PRC', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNMBR', 'QLN', M, M, N, -1 ) )
+                  MAXWRK = MAXWRK + M*N
+                  MINWRK = MINWRK + M*M
+               ELSE IF( WNTQS ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'PRC', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) )
+               ELSE IF( WNTQA ) THEN
+                  MAXWRK = MAX( MAXWRK, 2*M+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'PRC', N, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'QLN', M, M, N, -1 ) )
+               END IF
+            END IF
+         END IF
+         MAXWRK = MAX( MAXWRK, MINWRK )
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = MAXWRK
+         IF( LWORK.LT.MINWRK .AND. LWORK.NE.LQUERV )
+     $      INFO = -13
+      END IF
+*
+*     Quick returns
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGESDD', -INFO )
+         RETURN
+      END IF
+      IF( LWORK.EQ.LQUERV )
+     $   RETURN
+      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.MNTHR1 ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1 (M much larger than N, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = 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( NWORK ),
+     $                      LWORK-NWORK+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
+               NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NRWORK = IE + N
+*
+*              Perform bidiagonal SVD, compute singular values only
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAN)
+*
+               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2 (M much larger than N, JOBZ='O')
+*              N left singular vectors to be overwritten on A and
+*              N right singular vectors to be computed in VT
+*
+               IU = 1
+*
+*              WORK(IU) is N by N
+*
+               LDWRKU = N
+               IR = IU + LDWRKU*N
+               IF( LWORK.GE.M*N+N*N+3*N ) THEN
+*
+*                 WORK(IR) is M by N
+*
+                  LDWRKR = M
+               ELSE
+                  LDWRKR = ( LWORK-N*N-3*N ) / N
+               END IF
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+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 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + N
+               NWORK = ITAUP + N
+*
+*              Bidiagonalize R in WORK(IR)
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+2*N*NB)
+*              (RWorkspace: need N)
+*
+               CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of R in WORK(IRU) and computing right singular vectors
+*              of R in WORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + N
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by the left singular vectors of R
+*              (CWorkspace: need 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
+     $                      LDWRKU )
+               CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by the right singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IU), storing result in WORK(IR) and copying to A
+*              (CWorkspace: need 2*N*N, prefer N*N+M*N)
+*              (RWorkspace: 0)
+*
+               DO 10 I = 1, M, LDWRKR
+                  CHUNK = MIN( M-I+1, LDWRKR )
+                  CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
+     $                        LDA, WORK( IU ), LDWRKU, CZERO,
+     $                        WORK( IR ), LDWRKR )
+                  CALL ZLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+     $                         A( I, 1 ), LDA )
+   10          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Path 3 (M much larger than N, JOBZ='S')
+*              N left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IR = 1
+*
+*              WORK(IR) is N by N
+*
+               LDWRKR = N
+               ITAU = IR + LDWRKR*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+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 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + N
+               NWORK = 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( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + N
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, WORK( IR ), LDWRKR,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in A by left singular vectors of R in
+*              WORK(IR), storing result in U
+*              (CWorkspace: need N*N)
+*              (RWorkspace: 0)
+*
+               CALL ZLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
+               CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, WORK( IR ),
+     $                     LDWRKR, CZERO, U, LDU )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 4 (M much larger than N, JOBZ='A')
+*              M left singular vectors to be computed in U and
+*              N right singular vectors to be computed in VT
+*
+               IU = 1
+*
+*              WORK(IU) is N by N
+*
+               LDWRKU = N
+               ITAU = IU + LDWRKU*N
+               NWORK = ITAU + N
+*
+*              Compute A=Q*R, copying result to U
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce R in A, zeroing out below it
+*
+               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + N
+               NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               IRU = IE + N
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by left singular vectors of R
+*              (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
+     $                      LDWRKU )
+               CALL ZUNMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
+     $                      WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of R
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Multiply Q in U by left singular vectors of R in
+*              WORK(IU), storing result in A
+*              (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 )
+*
+            END IF
+*
+         ELSE IF( M.GE.MNTHR2 ) THEN
+*
+*           MNTHR2 <= M < MNTHR1
+*
+*           Path 5 (M much larger than N, but not as much as MNTHR1)
+*           Reduce to bidiagonal form without QR decomposition, use
+*           ZUNGBR and matrix multiplication to compute singular vectors
+*
+            IE = 1
+            NRWORK = IE + N
+            ITAUQ = 1
+            ITAUP = ITAUQ + N
+            NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IU = NWORK
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Generate Q in A
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*N ) THEN
+*
+*                 WORK( IU ) is M by N
+*
+                  LDWRKU = M
+               ELSE
+*
+*                 WORK(IU) is LDWRKU by N
+*
+                  LDWRKU = ( LWORK-3*N ) / N
+               END IF
+               NWORK = IU + LDWRKU*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in WORK(IU), copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 3*N*N)
+*
+               CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT,
+     $                      WORK( IU ), LDWRKU, RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', N, N, WORK( IU ), LDWRKU, VT, LDVT )
+*
+*              Multiply Q in A by real matrix RWORK(IRU), storing the
+*              result in WORK(IU), copying to A
+*              (CWorkspace: need N*N, prefer M*N)
+*              (Rworkspace: need 3*N*N, prefer N*N+2*M*N)
+*
+               NRWORK = IRVT
+               DO 20 I = 1, M, LDWRKU
+                  CHUNK = MIN( M-I+1, LDWRKU )
+                  CALL ZLACRM( CHUNK, N, A( I, 1 ), LDA, RWORK( IRU ),
+     $                         N, WORK( IU ), LDWRKU, RWORK( NRWORK ) )
+                  CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                         A( I, 1 ), LDA )
+   20          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+               CALL ZUNGBR( 'Q', M, N, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 3*N*N)
+*
+               CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: need 0)
+*              (Rworkspace: need N*N+2*M*N)
+*
+               NRWORK = IRVT
+               CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
+            ELSE
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 3*N*N)
+*
+               CALL ZLARCM( N, N, RWORK( IRVT ), N, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: 0)
+*              (Rworkspace: need 3*N*N)
+*
+               NRWORK = IRVT
+               CALL ZLACRM( M, N, U, LDU, RWORK( IRU ), N, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
+            END IF
+*
+         ELSE
+*
+*           M .LT. MNTHR2
+*
+*           Path 6 (M at least N, but not much larger)
+*           Reduce to bidiagonal form without QR decomposition
+*           Use ZUNMBR to compute singular vectors
+*
+            IE = 1
+            NRWORK = IE + N
+            ITAUQ = 1
+            ITAUP = ITAUQ + N
+            NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL DBDSDC( 'U', 'N', N, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IU = NWORK
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               IF( LWORK.GE.M*N+3*N ) THEN
+*
+*                 WORK( IU ) is M by N
+*
+                  LDWRKU = M
+               ELSE
+*
+*                 WORK( IU ) is LDWRKU by N
+*
+                  LDWRKU = ( LWORK-3*N ) / N
+               END IF
+               NWORK = IU + LDWRKU*N
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (Cworkspace: need 2*N, prefer N+N*NB)
+*              (Rworkspace: need 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*N ) THEN
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by left singular vectors of A, copying
+*              to A
+*              (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB)
+*              (Rworkspace: need 0)
+*
+                  CALL ZLASET( 'F', M, N, CZERO, CZERO, WORK( IU ),
+     $                         LDWRKU )
+                  CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, WORK( IU ),
+     $                         LDWRKU )
+                  CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                         WORK( ITAUQ ), WORK( IU ), LDWRKU,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+                  CALL ZLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
+               ELSE
+*
+*                 Generate Q in A
+*                 (Cworkspace: need 2*N, prefer N+N*NB)
+*                 (Rworkspace: need 0)
+*
+                  CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by real matrix RWORK(IRU), storing the
+*                 result in WORK(IU), copying to A
+*                 (CWorkspace: need N*N, prefer M*N)
+*                 (Rworkspace: need 3*N*N, prefer N*N+2*M*N)
+*
+                  NRWORK = IRVT
+                  DO 30 I = 1, M, LDWRKU
+                     CHUNK = MIN( M-I+1, LDWRKU )
+                     CALL ZLACRM( CHUNK, N, A( I, 1 ), LDA,
+     $                            RWORK( IRU ), N, WORK( IU ), LDWRKU,
+     $                            RWORK( NRWORK ) )
+                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                            A( I, 1 ), LDA )
+   30             CONTINUE
+               END IF
+*
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLASET( 'F', M, N, CZERO, CZERO, U, LDU )
+               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = NRWORK
+               IRVT = IRU + N*N
+               NRWORK = IRVT + N*N
+               CALL DBDSDC( 'U', 'I', N, S, RWORK( IE ), RWORK( IRU ),
+     $                      N, RWORK( IRVT ), N, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Set the right corner of U to identity matrix
+*
+               CALL ZLASET( 'F', M, M, CZERO, CZERO, U, LDU )
+               IF( M.GT.N ) THEN
+                  CALL ZLASET( 'F', M-N, M-N, CZERO, CONE,
+     $                         U( N+1, N+1 ), LDU )
+               END IF
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRU ), N, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', N, N, RWORK( IRVT ), N, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, N, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      ELSE
+*
+*        A has more columns than rows. If A has sufficiently more
+*        columns than rows, first reduce using the LQ decomposition (if
+*        sufficient workspace available)
+*
+         IF( N.GE.MNTHR1 ) THEN
+*
+            IF( WNTQN ) THEN
+*
+*              Path 1t (N much larger than M, JOBZ='N')
+*              No singular vectors to be computed
+*
+               ITAU = 1
+               NWORK = 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( NWORK ),
+     $                      LWORK-NWORK+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
+               NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+               NRWORK = IE + M
+*
+*              Perform bidiagonal SVD, compute singular values only
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAN)
+*
+               CALL DBDSDC( 'U', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+*
+            ELSE IF( WNTQO ) THEN
+*
+*              Path 2t (N much larger than M, JOBZ='O')
+*              M right singular vectors to be overwritten on A and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+               LDWKVT = M
+*
+*              WORK(IVT) is M by M
+*
+               IL = IVT + LDWKVT*M
+               IF( LWORK.GE.M*N+M*M+3*M ) THEN
+*
+*                 WORK(IL) M by N
+*
+                  LDWRKL = M
+                  CHUNK = N
+               ELSE
+*
+*                 WORK(IL) is M by CHUNK
+*
+                  LDWRKL = M
+                  CHUNK = ( LWORK-M*M-3*M ) / M
+               END IF
+               ITAU = IL + LDWRKL*CHUNK
+               NWORK = 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( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing about above it
+*
+               CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              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( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IL)
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL ZGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + M
+               IRVT = IRU + M*M
+               NRWORK = IRVT + M*M
+               CALL DBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix WORK(IU)
+*              Overwrite WORK(IU) by the left singular vectors of L
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
+*              Overwrite WORK(IVT) by the right singular vectors of L
+*              (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
+     $                      LDWKVT )
+               CALL ZUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IL) by Q
+*              in A, storing result in WORK(IL) and copying to A
+*              (CWorkspace: need 2*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( IVT ), M,
+     $                        A( 1, I ), LDA, CZERO, WORK( IL ),
+     $                        LDWRKL )
+                  CALL ZLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
+     $                         A( 1, I ), LDA )
+   40          CONTINUE
+*
+            ELSE IF( WNTQS ) THEN
+*
+*             Path 3t (N much larger than M, JOBZ='S')
+*             M right singular vectors to be computed in VT and
+*             M left singular vectors to be computed in U
+*
+               IL = 1
+*
+*              WORK(IL) is M by M
+*
+               LDWRKL = M
+               ITAU = IL + LDWRKL*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy L to WORK(IL), zeroing out above it
+*
+               CALL ZLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                      WORK( IL+LDWRKL ), LDWRKL )
+*
+*              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( NWORK ), LWORK-NWORK+1, IERR )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in WORK(IL)
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL ZGEBRD( M, M, WORK( IL ), LDWRKL, S, RWORK( IE ),
+     $                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + M
+               IRVT = IRU + M*M
+               NRWORK = IRVT + M*M
+               CALL DBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of L
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by left singular vectors of L
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', M, M, M, WORK( IL ), LDWRKL,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy VT to WORK(IL), multiply right singular vectors of L
+*              in WORK(IL) by Q in A, storing result in VT
+*              (CWorkspace: need M*M)
+*              (RWorkspace: 0)
+*
+               CALL ZLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
+               CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IL ), LDWRKL,
+     $                     A, LDA, CZERO, VT, LDVT )
+*
+            ELSE IF( WNTQA ) THEN
+*
+*              Path 9t (N much larger than M, JOBZ='A')
+*              N right singular vectors to be computed in VT and
+*              M left singular vectors to be computed in U
+*
+               IVT = 1
+*
+*              WORK(IVT) is M by M
+*
+               LDWKVT = M
+               ITAU = IVT + LDWKVT*M
+               NWORK = ITAU + M
+*
+*              Compute A=L*Q, copying result to VT
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+     $                      LWORK-NWORK+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( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Produce L in A, zeroing out above it
+*
+               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = ITAU
+               ITAUP = ITAUQ + M
+               NWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+     $                      IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRU = IE + M
+               IRVT = IRU + M*M
+               NRWORK = IRVT + M*M
+               CALL DBDSDC( 'U', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of L
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
+*              Overwrite WORK(IVT) by right singular vectors of L
+*              (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
+     $                      LDWKVT )
+               CALL ZUNMBR( 'P', 'R', 'C', M, M, M, A, LDA,
+     $                      WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Multiply right singular vectors of L in WORK(IVT) by
+*              Q in VT, storing result in A
+*              (CWorkspace: need M*M)
+*              (RWorkspace: 0)
+*
+               CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IVT ), LDWKVT,
+     $                     VT, LDVT, CZERO, A, LDA )
+*
+*              Copy right singular vectors of A from A to VT
+*
+               CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+            END IF
+*
+         ELSE IF( N.GE.MNTHR2 ) THEN
+*
+*           MNTHR2 <= N < MNTHR1
+*
+*           Path 5t (N much larger than M, but not as much as MNTHR1)
+*           Reduce to bidiagonal form without QR decomposition, use
+*           ZUNGBR and matrix multiplication to compute singular vectors
+*
+*
+            IE = 1
+            NRWORK = IE + M
+            ITAUQ = 1
+            ITAUP = ITAUQ + M
+            NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+*
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               IVT = NWORK
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Generate P**H in A
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+               LDWKVT = M
+               IF( LWORK.GE.M*N+3*M ) THEN
+*
+*                 WORK( IVT ) is M by N
+*
+                  NWORK = IVT + LDWKVT*N
+                  CHUNK = N
+               ELSE
+*
+*                 WORK( IVT ) is M by CHUNK
+*
+                  CHUNK = ( LWORK-3*M ) / M
+                  NWORK = IVT + LDWKVT*CHUNK
+               END IF
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply Q in U by real matrix RWORK(IRVT)
+*              storing the result in WORK(IVT), copying to U
+*              (Cworkspace: need 0)
+*              (Rworkspace: need 2*M*M)
+*
+               CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, WORK( IVT ),
+     $                      LDWKVT, RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, M, WORK( IVT ), LDWKVT, U, LDU )
+*
+*              Multiply RWORK(IRVT) by P**H in A, storing the
+*              result in WORK(IVT), copying to A
+*              (CWorkspace: need M*M, prefer M*N)
+*              (Rworkspace: need 2*M*M, prefer 2*M*N)
+*
+               NRWORK = IRU
+               DO 50 I = 1, N, CHUNK
+                  BLK = MIN( N-I+1, CHUNK )
+                  CALL ZLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ), LDA,
+     $                         WORK( IVT ), LDWKVT, RWORK( NRWORK ) )
+                  CALL ZLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
+     $                         A( 1, I ), LDA )
+   50          CONTINUE
+            ELSE IF( WNTQS ) THEN
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               CALL ZUNGBR( 'P', M, N, M, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: need 0)
+*              (Rworkspace: need 3*M*M)
+*
+               CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need M*M+2*M*N)
+*
+               NRWORK = IRU
+               CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
+            ELSE
+*
+*              Copy A to U, generate Q
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Copy A to VT, generate P**H
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: 0)
+*
+               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               CALL ZUNGBR( 'P', N, N, M, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Multiply Q in U by real matrix RWORK(IRU), storing the
+*              result in A, copying to U
+*              (CWorkspace: need 0)
+*              (Rworkspace: need 3*M*M)
+*
+               CALL ZLACRM( M, M, U, LDU, RWORK( IRU ), M, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+*              Multiply real matrix RWORK(IRVT) by P**H in VT,
+*              storing the result in A, copying to VT
+*              (Cworkspace: need 0)
+*              (Rworkspace: need M*M+2*M*N)
+*
+               CALL ZLARCM( M, N, RWORK( IRVT ), M, VT, LDVT, A, LDA,
+     $                      RWORK( NRWORK ) )
+               CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
+            END IF
+*
+         ELSE
+*
+*           N .LT. MNTHR2
+*
+*           Path 6t (N greater than M, but not much larger)
+*           Reduce to bidiagonal form without LQ decomposition
+*           Use ZUNMBR to compute singular vectors
+*
+            IE = 1
+            NRWORK = IE + M
+            ITAUQ = 1
+            ITAUP = ITAUQ + M
+            NWORK = 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( NWORK ), LWORK-NWORK+1,
+     $                   IERR )
+            IF( WNTQN ) THEN
+*
+*              Compute singular values only
+*              (Cworkspace: 0)
+*              (Rworkspace: need BDSPAN)
+*
+               CALL DBDSDC( 'L', 'N', M, S, RWORK( IE ), DUM, 1, DUM, 1,
+     $                      DUM, IDUM, RWORK( NRWORK ), IWORK, INFO )
+            ELSE IF( WNTQO ) THEN
+               LDWKVT = M
+               IVT = NWORK
+               IF( LWORK.GE.M*N+3*M ) THEN
+*
+*                 WORK( IVT ) is M by N
+*
+                  CALL ZLASET( 'F', M, N, CZERO, CZERO, WORK( IVT ),
+     $                         LDWKVT )
+                  NWORK = IVT + LDWKVT*N
+               ELSE
+*
+*                 WORK( IVT ) is M by CHUNK
+*
+                  CHUNK = ( LWORK-3*M ) / M
+                  NWORK = IVT + LDWKVT*CHUNK
+               END IF
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (Cworkspace: need 2*M, prefer M+M*NB)
+*              (Rworkspace: need 0)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+               IF( LWORK.GE.M*N+3*M ) THEN
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT)
+*              Overwrite WORK(IVT) by right singular vectors of A,
+*              copying to A
+*              (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB)
+*              (Rworkspace: need 0)
+*
+                  CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, WORK( IVT ),
+     $                         LDWKVT )
+                  CALL ZUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
+     $                         WORK( ITAUP ), WORK( IVT ), LDWKVT,
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+                  CALL ZLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
+               ELSE
+*
+*                 Generate P**H in A
+*                 (Cworkspace: need 2*M, prefer M+M*NB)
+*                 (Rworkspace: need 0)
+*
+                  CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                         WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+*                 Multiply Q in A by real matrix RWORK(IRU), storing the
+*                 result in WORK(IU), copying to A
+*                 (CWorkspace: need M*M, prefer M*N)
+*                 (Rworkspace: need 3*M*M, prefer M*M+2*M*N)
+*
+                  NRWORK = IRU
+                  DO 60 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL ZLARCM( M, BLK, RWORK( IRVT ), M, A( 1, I ),
+     $                            LDA, WORK( IVT ), LDWKVT,
+     $                            RWORK( NRWORK ) )
+                     CALL ZLACPY( 'F', M, BLK, WORK( IVT ), LDWKVT,
+     $                            A( 1, I ), LDA )
+   60             CONTINUE
+               END IF
+            ELSE IF( WNTQS ) THEN
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: M*M)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: M*M)
+*
+               CALL ZLASET( 'F', M, N, CZERO, CZERO, VT, LDVT )
+               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', M, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            ELSE
+*
+*              Perform bidiagonal SVD, computing left singular vectors
+*              of bidiagonal matrix in RWORK(IRU) and computing right
+*              singular vectors of bidiagonal matrix in RWORK(IRVT)
+*              (CWorkspace: need 0)
+*              (RWorkspace: need BDSPAC)
+*
+               IRVT = NRWORK
+               IRU = IRVT + M*M
+               NRWORK = IRU + M*M
+*
+               CALL DBDSDC( 'L', 'I', M, S, RWORK( IE ), RWORK( IRU ),
+     $                      M, RWORK( IRVT ), M, DUM, IDUM,
+     $                      RWORK( NRWORK ), IWORK, INFO )
+*
+*              Copy real matrix RWORK(IRU) to complex matrix U
+*              Overwrite U by left singular vectors of A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: M*M)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRU ), M, U, LDU )
+               CALL ZUNMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+     $                      WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+*
+*              Set all of VT to identity matrix
+*
+               CALL ZLASET( 'F', N, N, CZERO, CONE, VT, LDVT )
+*
+*              Copy real matrix RWORK(IRVT) to complex matrix VT
+*              Overwrite VT by right singular vectors of A
+*              (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*              (RWorkspace: M*M)
+*
+               CALL ZLACP2( 'F', M, M, RWORK( IRVT ), M, VT, LDVT )
+               CALL ZUNMBR( 'P', 'R', 'C', N, N, M, A, LDA,
+     $                      WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+     $                      LWORK-NWORK+1, IERR )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ISCL.EQ.1 ) THEN
+         IF( ANRM.GT.BIGNUM )
+     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( 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 ZGESDD
+*
+      END
diff --git a/SRC/zgesv.f b/SRC/zgesv.f
new file mode 100644
index 00000000..b5f61f82
--- /dev/null
+++ b/SRC/zgesv.f
@@ -0,0 +1,107 @@
+      SUBROUTINE ZGESV( 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( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGESV computes the solution to a complex 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) COMPLEX*16 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) COMPLEX*16 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           XERBLA, ZGETRF, ZGETRS
+*     ..
+*     .. 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( 'ZGESV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of A.
+*
+      CALL ZGETRF( N, N, A, LDA, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
+     $                INFO )
+      END IF
+      RETURN
+*
+*     End of ZGESV
+*
+      END
diff --git a/SRC/zgesvd.f b/SRC/zgesvd.f
new file mode 100644
index 00000000..7b238d8b
--- /dev/null
+++ b/SRC/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/zgesvx.f b/SRC/zgesvx.f
new file mode 100644
index 00000000..8c715d44
--- /dev/null
+++ b/SRC/zgesvx.f
@@ -0,0 +1,481 @@
+      SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
+     $                   EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, RWORK, 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( * )
+      DOUBLE PRECISION   BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGESVX uses the LU factorization to compute the solution to a complex
+*  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  (Conjugate 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) COMPLEX*16 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) COMPLEX*16 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 ZGETRF.  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 ZGETRF; 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (2*N)
+*          On exit, RWORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If RWORK(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
+*          RWORK(1) contains the reciprocal pivot growth factor for the
+*          leading INFO columns of A.
+*
+*  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, ZLANGE, ZLANTR
+      EXTERNAL           LSAME, DLAMCH, ZLANGE, ZLANTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGECON, ZGEEQU, ZGERFS, ZGETRF, ZGETRS,
+     $                   ZLACPY, ZLAQGE
+*     ..
+*     .. 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( 'ZGESVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL ZGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL ZLAQGE( 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 ZLACPY( 'Full', N, N, A, LDA, AF, LDAF )
+         CALL ZGETRF( 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 = ZLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
+     $               RWORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = ZLANGE( 'M', N, INFO, A, LDA, RWORK ) /
+     $                  RPVGRW
+            END IF
+            RWORK( 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 = ZLANGE( NORM, N, N, A, LDA, RWORK )
+      RPVGRW = ZLANTR( 'M', 'U', 'N', N, N, AF, LDAF, RWORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = ZLANGE( 'M', N, N, A, LDA, RWORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZGETRS( 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 ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, 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
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RWORK( 1 ) = RPVGRW
+      RETURN
+*
+*     End of ZGESVX
+*
+      END
diff --git a/SRC/zgetc2.f b/SRC/zgetc2.f
new file mode 100644
index 00000000..35ac376c
--- /dev/null
+++ b/SRC/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/zgetf2.f b/SRC/zgetf2.f
new file mode 100644
index 00000000..a2dc1834
--- /dev/null
+++ b/SRC/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/zgetrf.f b/SRC/zgetrf.f
new file mode 100644
index 00000000..9c7bfbbf
--- /dev/null
+++ b/SRC/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/zgetri.f b/SRC/zgetri.f
new file mode 100644
index 00000000..685518e6
--- /dev/null
+++ b/SRC/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/zgetrs.f b/SRC/zgetrs.f
new file mode 100644
index 00000000..e32549cd
--- /dev/null
+++ b/SRC/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/zggbak.f b/SRC/zggbak.f
new file mode 100644
index 00000000..ad6dd032
--- /dev/null
+++ b/SRC/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/zggbal.f b/SRC/zggbal.f
new file mode 100644
index 00000000..b75ae456
--- /dev/null
+++ b/SRC/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/zgges.f b/SRC/zgges.f
new file mode 100644
index 00000000..c1499003
--- /dev/null
+++ b/SRC/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/zggesx.f b/SRC/zggesx.f
new file mode 100644
index 00000000..84c1a183
--- /dev/null
+++ b/SRC/zggesx.f
@@ -0,0 +1,578 @@
+      SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
+     $                   B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR,
+     $                   LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK,
+     $                   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          JOBVSL, JOBVSR, SENSE, SORT
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
+     $                   SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RCONDE( 2 ), RCONDV( 2 ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices
+*  (A,B), the generalized eigenvalues, the complex Schur form (S,T),
+*  and, optionally, the left and/or right matrices of Schur vectors (VSL
+*  and VSR).  This gives the generalized Schur factorization
+*
+*       (A,B) = ( (VSL) S (VSR)**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; computes
+*  a reciprocal condition number for the average of the selected
+*  eigenvalues (RCONDE); and computes a reciprocal condition number for
+*  the right and left deflating subspaces corresponding to the selected
+*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form
+*  an orthonormal basis for the corresponding left and right eigenspaces
+*  (deflating subspaces).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
+*  usually represented as the pair (alpha,beta), as there is a
+*  reasonable interpretation for beta=0 or for both being zero.
+*
+*  A pair of matrices (S,T) is in generalized complex Schur form if T is
+*  upper triangular with non-negative diagonal and S is upper
+*  triangular.
+*
+*  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.
+*          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+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 deflating subspaces only;
+*          = 'B' : Computed for both.
+*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
+*
+*  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) and BETA(j),j=1,...,N  are
+*          the diagonals of the complex Schur form (S,T).  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.
+*
+*  RCONDE  (output) DOUBLE PRECISION array, dimension ( 2 )
+*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
+*          reciprocal condition numbers for the average of the selected
+*          eigenvalues.
+*          Not referenced if SENSE = 'N' or 'V'.
+*
+*  RCONDV  (output) DOUBLE PRECISION array, dimension ( 2 )
+*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
+*          reciprocal condition number for the selected deflating
+*          subspaces.
+*          Not referenced if SENSE = 'N' or 'E'.
+*
+*  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 N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
+*          LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else
+*          LWORK >= MAX(1,2*N).  Note that 2*SDIM*(N-SDIM) <= N*N/2.
+*          Note also that an error is only returned if
+*          LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may
+*          not be large enough.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the bound on the optimal size of the WORK
+*          array and the minimum size of the IWORK array, returns these
+*          values as the first entries of the WORK and IWORK arrays, and
+*          no error message related to LWORK or LIWORK is issued by
+*          XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension ( 8*N )
+*          Real workspace.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
+*          LIWORK >= N+2.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the bound on the optimal size of the
+*          WORK array and the minimum size of the IWORK array, returns
+*          these values as the first entries of the WORK and IWORK
+*          arrays, and no error message related to LWORK or LIWORK is
+*          issued by XERBLA.
+*
+*  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 failed in ZTGSEN.
+*
+*  =====================================================================
+*
+*     .. 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            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+     $                   LQUERY, WANTSB, WANTSE, WANTSN, WANTST, WANTSV
+      INTEGER            I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
+     $                   ILEFT, ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK,
+     $                   LIWMIN, LWRK, MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
+     $                   PR, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      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' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+      IF( WANTSN ) THEN
+         IJOB = 0
+      ELSE IF( WANTSE ) THEN
+         IJOB = 1
+      ELSE IF( WANTSV ) THEN
+         IJOB = 2
+      ELSE IF( WANTSB ) THEN
+         IJOB = 4
+      END IF
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+     $         ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -15
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -17
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.GT.0) THEN
+            MINWRK = 2*N
+            MAXWRK = N*(1 + ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) )
+            MAXWRK = MAX( MAXWRK, N*( 1 +
+     $                    ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, -1 ) ) )
+            IF( ILVSL ) THEN
+               MAXWRK = MAX( MAXWRK, N*( 1 +
+     $                       ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) ) )
+            END IF
+            LWRK = MAXWRK
+            IF( IJOB.GE.1 )
+     $         LWRK = MAX( LWRK, N*N/2 )
+         ELSE
+            MINWRK = 1
+            MAXWRK = 1
+            LWRK   = 1
+         END IF
+         WORK( 1 ) = LWRK
+         IF( WANTSN .OR. N.EQ.0 ) THEN
+            LIWMIN = 1
+         ELSE
+            LIWMIN = N + 2
+         END IF
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -21
+         ELSE IF( LIWORK.LT.LIWMIN  .AND. .NOT.LQUERY) THEN
+            INFO = -24
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGESX', -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 unitary 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 40
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA and compute the reciprocal of
+*     condition number(s)
+*
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before SELCTGing
+*
+         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 )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues, transform Generalized Schur vectors, and
+*        compute reciprocal condition numbers
+*        (Complex Workspace: If IJOB >= 1, need MAX(1, 2*SDIM*(N-SDIM))
+*                            otherwise, need 1 )
+*
+         CALL ZTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
+     $                ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PL, PR,
+     $                DIF, WORK( IWRK ), LWORK-IWRK+1, IWORK, LIWORK,
+     $                IERR )
+*
+         IF( IJOB.GE.1 )
+     $      MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+         IF( IERR.EQ.-21 ) THEN
+*
+*            not enough complex workspace
+*
+            INFO = -21
+         ELSE
+            IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
+               RCONDE( 1 ) = PL
+               RCONDE( 2 ) = PR
+            END IF
+            IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+               RCONDV( 1 ) = DIF( 1 )
+               RCONDV( 2 ) = DIF( 2 )
+            END IF
+            IF( IERR.EQ.1 )
+     $         INFO = N + 3
+         END IF
+*
+      END IF
+*
+*     Apply permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL 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 30 I = 1, N
+            CURSL = SELCTG( ALPHA( I ), BETA( I ) )
+            IF( CURSL )
+     $         SDIM = SDIM + 1
+            IF( CURSL .AND. .NOT.LASTSL )
+     $         INFO = N + 2
+            LASTSL = CURSL
+   30    CONTINUE
+*
+      END IF
+*
+   40 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of ZGGESX
+*
+      END
diff --git a/SRC/zggev.f b/SRC/zggev.f
new file mode 100644
index 00000000..94fb3dc2
--- /dev/null
+++ b/SRC/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/zggevx.f b/SRC/zggevx.f
new file mode 100644
index 00000000..b12e513a
--- /dev/null
+++ b/SRC/zggevx.f
@@ -0,0 +1,652 @@
+      SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
+     $                   ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI,
+     $                   LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV,
+     $                   WORK, LWORK, RWORK, IWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
+      INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+      DOUBLE PRECISION   ABNRM, BBNRM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   LSCALE( * ), RCONDE( * ), RCONDV( * ),
+     $                   RSCALE( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGEVX 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.
+*
+*  Optionally, it also computes a balancing transformation to improve
+*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
+*  the eigenvalues (RCONDE), and reciprocal condition numbers for the
+*  right eigenvectors (RCONDV).
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+*  singular. It is usually represented as the pair (alpha,beta), as
+*  there is a reasonable interpretation for beta=0, and even for both
+*  being zero.
+*
+*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*                   A * v(j) = lambda(j) * B * v(j) .
+*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*                   u(j)**H * A  = lambda(j) * u(j)**H * B.
+*  where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+*  Arguments
+*  =========
+*
+*  BALANC  (input) CHARACTER*1
+*          Specifies the balance option to be performed:
+*          = 'N':  do not diagonally scale or permute;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*          Computed reciprocal condition numbers will be for the
+*          matrices after permuting and/or balancing. Permuting does
+*          not change condition numbers (in exact arithmetic), but
+*          balancing does.
+*
+*  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.
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': none are computed;
+*          = 'E': computed for eigenvalues only;
+*          = 'V': computed for eigenvectors only;
+*          = 'B': computed for eigenvalues and eigenvectors.
+*
+*  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. If JOBVL='V' or JOBVR='V'
+*          or both, then A contains the first part of the complex Schur
+*          form of the "balanced" versions of the input A and B.
+*
+*  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. If JOBVL='V' or JOBVR='V'
+*          or both, then B contains the second part of the complex
+*          Schur form of the "balanced" versions of the input A and B.
+*
+*  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 quotient 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 will be scaled so the largest component
+*          will have 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 will be scaled so the largest component
+*          will have 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.
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are integer values such that on exit
+*          A(i,j) = 0 and B(i,j) = 0 if i > j and
+*          j = 1,...,ILO-1 or i = IHI+1,...,N.
+*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the left side of A and B.  If PL(j) is the index of the
+*          row interchanged with row j, and DL(j) is the scaling
+*          factor applied to row j, then
+*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1
+*                      = DL(j)  for j = ILO,...,IHI
+*                      = PL(j)  for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the right side of A and B.  If PR(j) is the index of the
+*          column interchanged with column j, and DR(j) is the scaling
+*          factor applied to column j, then
+*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1
+*                      = DR(j)  for j = ILO,...,IHI
+*                      = PR(j)  for j = IHI+1,...,N
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  ABNRM   (output) DOUBLE PRECISION
+*          The one-norm of the balanced matrix A.
+*
+*  BBNRM   (output) DOUBLE PRECISION
+*          The one-norm of the balanced matrix B.
+*
+*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)
+*          If SENSE = 'E' or 'B', the reciprocal condition numbers of
+*          the eigenvalues, stored in consecutive elements of the array.
+*          If SENSE = 'N' or 'V', RCONDE is not referenced.
+*
+*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the eigenvectors, stored in consecutive elements
+*          of the array. If the eigenvalues cannot be reordered to
+*          compute RCONDV(j), RCONDV(j) is set to 0; this can only occur
+*          when the true value would be very small anyway.
+*          If SENSE = 'N' or 'E', RCONDV is not referenced.
+*
+*  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).
+*          If SENSE = 'E', LWORK >= max(1,4*N).
+*          If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*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) REAL array, dimension (lrwork)
+*          lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',
+*          and at least max(1,2*N) otherwise.
+*          Real workspace.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N+2)
+*          If SENSE = 'E', IWORK is not referenced.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          If SENSE = 'N', BWORK is not referenced.
+*
+*  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 than QZ iteration failed in ZHGEQZ.
+*                =N+2: error return from ZTGEVC.
+*
+*  Further Details
+*  ===============
+*
+*  Balancing a matrix pair (A,B) includes, first, permuting rows and
+*  columns to isolate eigenvalues, second, applying diagonal similarity
+*  transformation to the rows and columns to make the rows and columns
+*  as close in norm as possible. The computed reciprocal condition
+*  numbers correspond to the balanced matrix. Permuting rows and columns
+*  will not change the condition numbers (in exact arithmetic) but
+*  diagonal scaling will.  For further explanation of balancing, see
+*  section 4.11.1.2 of LAPACK Users' Guide.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
+*
+*  An approximate error bound for the angle between the i-th computed
+*  eigenvector VL(i) or VR(i) is given by
+*
+*       EPS * norm(ABNRM, BBNRM) / DIF(i).
+*
+*  For further explanation of the reciprocal condition numbers RCONDE
+*  and RCONDV, see section 4.11 of LAPACK User's Guide.
+*
+*     .. 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            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
+     $                   WANTSB, WANTSE, WANTSN, WANTSV
+      CHARACTER          CHTEMP
+      INTEGER            I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
+     $                   ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+      COMPLEX*16         X
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, DLASCL, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL,
+     $                   ZGGHRD, ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC,
+     $                   ZTGSNA, 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
+*
+      NOSCL  = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.( NOSCL .OR. LSAME( BALANC,'S' ) .OR.
+     $    LSAME( BALANC, 'B' ) ) ) THEN
+         INFO = -1
+      ELSE IF( IJOBVL.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
+     $          THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -15
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV. The workspace is
+*       computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MINWRK = 2*N
+            IF( WANTSE ) THEN
+               MINWRK = 4*N
+            ELSE IF( WANTSV .OR. WANTSB ) THEN
+               MINWRK = 2*N*( N + 1)
+            END IF
+            MAXWRK = MINWRK
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) )
+            MAXWRK = MAX( MAXWRK,
+     $                    N + N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, 0 ) )
+            IF( ILVL ) THEN
+               MAXWRK = MAX( MAXWRK, N +
+     $                       N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, 0 ) )
+            END IF 
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -25
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGEVX', -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, 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 and/or balance the matrix pair (A,B)
+*     (Real Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
+*
+      CALL ZGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+     $             RWORK, IERR )
+*
+*     Compute ABNRM and BBNRM
+*
+      ABNRM = ZLANGE( '1', N, N, A, LDA, RWORK( 1 ) )
+      IF( ILASCL ) THEN
+         RWORK( 1 ) = ABNRM
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, RWORK( 1 ), 1,
+     $                IERR )
+         ABNRM = RWORK( 1 )
+      END IF
+*
+      BBNRM = ZLANGE( '1', N, N, B, LDB, RWORK( 1 ) )
+      IF( ILBSCL ) THEN
+         RWORK( 1 ) = BBNRM
+         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, RWORK( 1 ), 1,
+     $                IERR )
+         BBNRM = RWORK( 1 )
+      END IF
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Complex Workspace: need N, prefer N*NB )
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWRK = ITAU + IROWS
+      CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the unitary transformation to 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 and/or VR
+*     (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
+*
+      IF( ILVR )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      IF( ILV .OR. .NOT.WANTSN ) 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 forms and Schur vectors)
+*     (Complex Workspace: need N)
+*     (Real Workspace: need N)
+*
+      IWRK = ITAU
+      IF( ILV .OR. .NOT.WANTSN ) 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, 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 90
+      END IF
+*
+*     Compute Eigenvectors and estimate condition numbers if desired
+*     ZTGEVC: (Complex Workspace: need 2*N )
+*             (Real Workspace:    need 2*N )
+*     ZTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B')
+*             (Integer Workspace: need N+2 )
+*
+      IF( ILV .OR. .NOT.WANTSN ) THEN
+         IF( ILV ) THEN
+            IF( ILVL ) THEN
+               IF( ILVR ) THEN
+                  CHTEMP = 'B'
+               ELSE
+                  CHTEMP = 'L'
+               END IF
+            ELSE
+               CHTEMP = 'R'
+            END IF
+*
+            CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, N, IN, WORK( IWRK ), RWORK,
+     $                   IERR )
+            IF( IERR.NE.0 ) THEN
+               INFO = N + 2
+               GO TO 90
+            END IF
+         END IF
+*
+         IF( .NOT.WANTSN ) THEN
+*
+*           compute eigenvectors (DTGEVC) and estimate condition
+*           numbers (DTGSNA). Note that the definition of the condition
+*           number is not invariant under transformation (u,v) to
+*           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
+*           Schur form (S,T), Q and Z are orthogonal matrices. In order
+*           to avoid using extra 2*N*N workspace, we have to
+*           re-calculate eigenvectors and estimate the condition numbers
+*           one at a time.
+*
+            DO 20 I = 1, N
+*
+               DO 10 J = 1, N
+                  BWORK( J ) = .FALSE.
+   10          CONTINUE
+               BWORK( I ) = .TRUE.
+*
+               IWRK = N + 1
+               IWRK1 = IWRK + N
+*
+               IF( WANTSE .OR. WANTSB ) THEN
+                  CALL ZTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
+     $                         WORK( 1 ), N, WORK( IWRK ), N, 1, M,
+     $                         WORK( IWRK1 ), RWORK, IERR )
+                  IF( IERR.NE.0 ) THEN
+                     INFO = N + 2
+                     GO TO 90
+                  END IF
+               END IF
+*
+               CALL ZTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
+     $                      WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
+     $                      RCONDV( I ), 1, M, WORK( IWRK1 ),
+     $                      LWORK-IWRK1+1, IWORK, IERR )
+*
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Undo balancing on VL and VR and normalization
+*     (Workspace: none needed)
+*
+      IF( ILVL ) THEN
+         CALL ZGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
+     $                LDVL, IERR )
+*
+         DO 50 JC = 1, N
+            TEMP = ZERO
+            DO 30 JR = 1, N
+               TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
+   30       CONTINUE
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 50
+            TEMP = ONE / TEMP
+            DO 40 JR = 1, N
+               VL( JR, JC ) = VL( JR, JC )*TEMP
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      IF( ILVR ) THEN
+         CALL ZGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
+     $                LDVR, IERR )
+         DO 80 JC = 1, N
+            TEMP = ZERO
+            DO 60 JR = 1, N
+               TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
+   60       CONTINUE
+            IF( TEMP.LT.SMLNUM )
+     $         GO TO 80
+            TEMP = ONE / TEMP
+            DO 70 JR = 1, N
+               VR( JR, JC ) = VR( JR, JC )*TEMP
+   70       CONTINUE
+   80    CONTINUE
+      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 )
+*
+   90 CONTINUE
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of ZGGEVX
+*
+      END
diff --git a/SRC/zggglm.f b/SRC/zggglm.f
new file mode 100644
index 00000000..4b18107a
--- /dev/null
+++ b/SRC/zggglm.f
@@ -0,0 +1,259 @@
+      SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, 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, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
+     $                   X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:
+*
+*          minimize || y ||_2   subject to   d = A*x + B*y
+*              x
+*
+*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
+*  given N-vector. It is assumed that M <= N <= M+P, and
+*
+*             rank(A) = M    and    rank( A B ) = N.
+*
+*  Under these assumptions, the constrained equation is always
+*  consistent, and there is a unique solution x and a minimal 2-norm
+*  solution y, which is obtained using a generalized QR factorization
+*  of the matrices (A, B) given by
+*
+*     A = Q*(R),   B = Q*T*Z.
+*           (0)
+*
+*  In particular, if matrix B is square nonsingular, then the problem
+*  GLM is equivalent to the following weighted linear least squares
+*  problem
+*
+*               minimize || inv(B)*(d-A*x) ||_2
+*                   x
+*
+*  where inv(B) denotes the inverse of B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B.  N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  0 <= M <= N.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= N-M.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the upper triangular part of the array A contains
+*          the M-by-M upper triangular matrix R.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  D       (input/output) COMPLEX*16 array, dimension (N)
+*          On entry, D is the left hand side of the GLM equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) COMPLEX*16 array, dimension (M)
+*  Y       (output) COMPLEX*16 array, dimension (P)
+*          On exit, X and Y are the solutions of the GLM problem.
+*
+*  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+M+P).
+*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.
+*
+*          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 upper triangular factor R associated with A in the
+*                generalized QR factorization of the pair (A, B) is
+*                singular, so that rank(A) < M; the least squares
+*                solution could not be computed.
+*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal
+*                factor T associated with B in the generalized QR
+*                factorization of the pair (A, B) is singular, so that
+*                rank( A B ) < N; the least squares solution could not
+*                be computed.
+*
+*  ===================================================================
+*
+*     .. Parameters ..
+      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, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
+     $                   NB4, NP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZGEMV, ZGGQRF, ZTRTRS, ZUNMQR,
+     $                   ZUNMRQ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV 
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NP = MIN( N, P )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'ZGEQRF', ' ', N, M, -1, -1 )
+            NB2 = ILAENV( 1, 'ZGERQF', ' ', N, M, -1, -1 )
+            NB3 = ILAENV( 1, 'ZUNMQR', ' ', N, M, P, -1 )
+            NB4 = ILAENV( 1, 'ZUNMRQ', ' ', N, M, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = M + NP + MAX( N, P )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGGLM', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GQR factorization of matrices A and B:
+*
+*            Q'*A = ( R11 ) M,    Q'*B*Z' = ( T11   T12 ) M
+*                   (  0  ) N-M             (  0    T22 ) N-M
+*                      M                     M+P-N  N-M
+*
+*     where R11 and T22 are upper triangular, and Q and Z are
+*     unitary.
+*
+      CALL ZGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
+     $             WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = WORK( M+NP+1 )
+*
+*     Update left-hand-side vector d = Q'*d = ( d1 ) M
+*                                             ( d2 ) N-M
+*
+      CALL ZUNMQR( 'Left', 'Conjugate transpose', N, 1, M, A, LDA, WORK,
+     $             D, MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+*     Solve T22*y2 = d2 for y2
+*
+      IF( N.GT.M ) THEN
+         CALL ZTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
+     $                B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+         CALL ZCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
+      END IF
+*
+*     Set y1 = 0
+*
+      DO 10 I = 1, M + P - N
+         Y( I ) = CZERO
+   10 CONTINUE
+*
+*     Update d1 = d1 - T12*y2
+*
+      CALL ZGEMV( 'No transpose', M, N-M, -CONE, B( 1, M+P-N+1 ), LDB,
+     $            Y( M+P-N+1 ), 1, CONE, D, 1 )
+*
+*     Solve triangular system: R11*x = d1
+*
+      IF( M.GT.0 ) THEN
+         CALL ZTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
+     $                D, M, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Copy D to X
+*
+         CALL ZCOPY( M, D, 1, X, 1 )
+      END IF
+*
+*     Backward transformation y = Z'*y
+*
+      CALL ZUNMRQ( 'Left', 'Conjugate transpose', P, 1, NP,
+     $             B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
+     $             MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+      RETURN
+*
+*     End of ZGGGLM
+*
+      END
diff --git a/SRC/zgghrd.f b/SRC/zgghrd.f
new file mode 100644
index 00000000..652c09d7
--- /dev/null
+++ b/SRC/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/zgglse.f b/SRC/zgglse.f
new file mode 100644
index 00000000..9a549237
--- /dev/null
+++ b/SRC/zgglse.f
@@ -0,0 +1,267 @@
+      SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
+     $                   INFO )
+*
+*  -- LAPACK driver routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     February 2007
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( * ), D( * ),
+     $                   WORK( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGLSE solves the linear equality-constrained least squares (LSE)
+*  problem:
+*
+*          minimize || c - A*x ||_2   subject to   B*x = d
+*
+*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
+*  M-vector, and d is a given P-vector. It is assumed that
+*  P <= N <= M+P, and
+*
+*           rank(B) = P and  rank( ( A ) ) = N.
+*                                ( ( B ) )
+*
+*  These conditions ensure that the LSE problem has a unique solution,
+*  which is obtained using a generalized RQ factorization of the
+*  matrices (B, A) given by
+*
+*     B = (0 R)*Q,   A = Z*T*Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B. 0 <= P <= N <= M+P.
+*
+*  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 T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
+*          contains the P-by-P upper triangular matrix R.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  C       (input/output) COMPLEX*16 array, dimension (M)
+*          On entry, C contains the right hand side vector for the
+*          least squares part of the LSE problem.
+*          On exit, the residual sum of squares for the solution
+*          is given by the sum of squares of elements N-P+1 to M of
+*          vector C.
+*
+*  D       (input/output) COMPLEX*16 array, dimension (P)
+*          On entry, D contains the right hand side vector for the
+*          constrained equation.
+*          On exit, D is destroyed.
+*
+*  X       (output) COMPLEX*16 array, dimension (N)
+*          On exit, X is the solution of the LSE problem.
+*
+*  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+N+P).
+*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
+*          where NB is an upper bound for the optimal blocksizes for
+*          ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.
+*
+*          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 upper triangular factor R associated with B in the
+*                generalized RQ factorization of the pair (B, A) is
+*                singular, so that rank(B) < P; the least squares
+*                solution could not be computed.
+*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor
+*                T associated with A in the generalized RQ factorization
+*                of the pair (B, A) is singular, so that
+*                rank( (A) ) < N; the least squares solution could not
+*                    ( (B) )
+*                be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
+     $                   NB4, NR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGEMV, ZGGRQF, ZTRMV,
+     $                   ZTRTRS, ZUNMQR, ZUNMRQ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Calculate workspace
+*
+      IF( INFO.EQ.0) THEN
+         IF( N.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+            NB2 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
+            NB3 = ILAENV( 1, 'ZUNMQR', ' ', M, N, P, -1 )
+            NB4 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, P, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = M + N + P
+            LWKOPT = P + MN + MAX( M, N )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGLSE', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the GRQ factorization of matrices B and A:
+*
+*            B*Q' = (  0  T12 ) P   Z'*A*Q' = ( R11 R12 ) N-P
+*                     N-P  P                  (  0  R22 ) M+P-N
+*                                               N-P  P
+*
+*     where T12 and R11 are upper triangular, and Q and Z are
+*     unitary.
+*
+      CALL ZGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
+     $             WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      LOPT = WORK( P+MN+1 )
+*
+*     Update c = Z'*c = ( c1 ) N-P
+*                       ( c2 ) M+P-N
+*
+      CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, 1, MN, A, LDA,
+     $             WORK( P+1 ), C, MAX( 1, M ), WORK( P+MN+1 ),
+     $             LWORK-P-MN, INFO )
+      LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+*     Solve T12*x2 = d for x2
+*
+      IF( P.GT.0 ) THEN
+         CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
+     $                B( 1, N-P+1 ), LDB, D, P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+*        Put the solution in X
+*
+         CALL ZCOPY( P, D, 1, X( N-P+1 ), 1 )
+*
+*        Update c1
+*
+         CALL ZGEMV( 'No transpose', N-P, P, -CONE, A( 1, N-P+1 ), LDA,
+     $               D, 1, CONE, C, 1 )
+      END IF
+*
+*     Solve R11*x1 = c1 for x1
+*
+      IF( N.GT.P ) THEN
+         CALL ZTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
+     $                A, LDA, C, N-P, INFO )
+*
+         IF( INFO.GT.0 ) THEN
+            INFO = 2
+            RETURN
+         END IF
+*
+*        Put the solutions in X
+*
+         CALL ZCOPY( N-P, C, 1, X, 1 )
+      END IF
+*
+*     Compute the residual vector:
+*
+      IF( M.LT.N ) THEN
+         NR = M + P - N
+         IF( NR.GT.0 )
+     $      CALL ZGEMV( 'No transpose', NR, N-M, -CONE, A( N-P+1, M+1 ),
+     $                  LDA, D( NR+1 ), 1, CONE, C( N-P+1 ), 1 )
+      ELSE
+         NR = P
+      END IF
+      IF( NR.GT.0 ) THEN
+         CALL ZTRMV( 'Upper', 'No transpose', 'Non unit', NR,
+     $               A( N-P+1, N-P+1 ), LDA, D, 1 )
+         CALL ZAXPY( NR, -CONE, D, 1, C( N-P+1 ), 1 )
+      END IF
+*
+*     Backward transformation x = Q'*x
+*
+      CALL ZUNMRQ( 'Left', 'Conjugate Transpose', N, 1, P, B, LDB,
+     $             WORK( 1 ), X, N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
+      WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+      RETURN
+*
+*     End of ZGGLSE
+*
+      END
diff --git a/SRC/zggqrf.f b/SRC/zggqrf.f
new file mode 100644
index 00000000..93b66cdf
--- /dev/null
+++ b/SRC/zggqrf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGQRF computes a generalized QR factorization of an N-by-M matrix A
+*  and an N-by-P matrix B:
+*
+*              A = Q*R,        B = Q*T*Z,
+*
+*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,
+*  and R and T assume one of the forms:
+*
+*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
+*                  (  0  ) N-M                         N   M-N
+*                     M
+*
+*  where R11 is upper triangular, and
+*
+*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
+*                   P-N  N                           ( T21 ) P
+*                                                       P
+*
+*  where T12 or T21 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GQR factorization
+*  of A and B implicitly gives the QR factorization of inv(B)*A:
+*
+*               inv(B)*A = Z'*(inv(T)*R)
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  conjugate transpose of matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrices A and B. N >= 0.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of columns of the matrix B.  P >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,M)
+*          On entry, the N-by-M matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
+*          upper triangular if N >= M); the elements below the diagonal,
+*          with the array TAUA, represent the unitary matrix Q as a
+*          product of min(N,M) elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAUA    (output) COMPLEX*16 array, dimension (min(N,M))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q (see Further Details).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,P)
+*          On entry, the N-by-P matrix B.
+*          On exit, if N <= P, the upper triangle of the subarray
+*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+*          if N > P, the elements on and above the (N-P)-th subdiagonal
+*          contain the N-by-P upper trapezoidal matrix T; the remaining
+*          elements, with the array TAUB, represent the unitary
+*          matrix Z as a product of elementary reflectors (see Further
+*          Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  TAUB    (output) COMPLEX*16 array, dimension (min(N,P))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Z (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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the QR factorization
+*          of an N-by-M matrix, NB2 is the optimal blocksize for the
+*          RQ factorization of an N-by-P matrix, and NB3 is the optimal
+*          blocksize for a call of ZUNMQR.
+*
+*          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(n,m).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taua * v * v'
+*
+*  where taua is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+*  and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine ZUNGQR.
+*  To use Q to update another matrix, use LAPACK subroutine ZUNMQR.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(n,p).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a complex scalar, and v is a complex vector with
+*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
+*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine ZUNGRQ.
+*  To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQRF, ZGERQF, ZUNMQR
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'ZGEQRF', ' ', N, M, -1, -1 )
+      NB2 = ILAENV( 1, 'ZGERQF', ' ', N, P, -1, -1 )
+      NB3 = ILAENV( 1, 'ZUNMQR', ' ', N, M, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     QR factorization of N-by-M matrix A: A = Q*R
+*
+      CALL ZGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := Q'*B.
+*
+      CALL ZUNMQR( 'Left', 'Conjugate Transpose', N, P, MIN( N, M ), A,
+     $             LDA, TAUA, B, LDB, WORK, LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     RQ factorization of N-by-P matrix B: B = T*Z.
+*
+      CALL ZGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of ZGGQRF
+*
+      END
diff --git a/SRC/zggrqf.f b/SRC/zggrqf.f
new file mode 100644
index 00000000..351fe7a1
--- /dev/null
+++ b/SRC/zggrqf.f
@@ -0,0 +1,211 @@
+      SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, 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, LDB, LWORK, M, N, P
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A
+*  and a P-by-N matrix B:
+*
+*              A = R*Q,        B = Z*T*Q,
+*
+*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary
+*  matrix, and R and T assume one of the forms:
+*
+*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
+*                   N-M  M                           ( R21 ) N
+*                                                       N
+*
+*  where R12 or R21 is upper triangular, and
+*
+*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
+*                  (  0  ) P-N                         P   N-P
+*                     N
+*
+*  where T11 is upper triangular.
+*
+*  In particular, if B is square and nonsingular, the GRQ factorization
+*  of A and B implicitly gives the RQ factorization of A*inv(B):
+*
+*               A*inv(B) = (R*inv(T))*Z'
+*
+*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+*  conjugate transpose of the matrix Z.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, if M <= N, the upper triangle of the subarray
+*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
+*          if M > N, the elements on and above the (M-N)-th subdiagonal
+*          contain the M-by-N upper trapezoidal matrix R; the remaining
+*          elements, with the array TAUA, represent the 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).
+*
+*  TAUA    (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q (see Further Details).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
+*          upper triangular if P >= N); the elements below the diagonal,
+*          with the array TAUB, represent the unitary matrix Z as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TAUB    (output) COMPLEX*16 array, dimension (min(P,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Z (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,M,P).
+*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+*          where NB1 is the optimal blocksize for the RQ factorization
+*          of an M-by-N matrix, NB2 is the optimal blocksize for the
+*          QR factorization of a P-by-N matrix, and NB3 is the optimal
+*          blocksize for a call of ZUNMRQ.
+*
+*          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 - taua * v * v'
+*
+*  where taua is a complex scalar, and v is a complex vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
+*  To form Q explicitly, use LAPACK subroutine ZUNGRQ.
+*  To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.
+*
+*  The matrix Z is represented as a product of elementary reflectors
+*
+*     Z = H(1) H(2) . . . H(k), where k = min(p,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - taub * v * v'
+*
+*  where taub is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
+*  and taub in TAUB(i).
+*  To form Z explicitly, use LAPACK subroutine ZUNGQR.
+*  To use Z to update another matrix, use LAPACK subroutine ZUNMQR.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQRF, ZGERQF, ZUNMRQ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'ZGEQRF', ' ', P, N, -1, -1 )
+      NB3 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, P, -1 )
+      NB = MAX( NB1, NB2, NB3 )
+      LWKOPT = MAX( N, M, P )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGRQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     RQ factorization of M-by-N matrix A: A = R*Q
+*
+      CALL ZGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
+      LOPT = WORK( 1 )
+*
+*     Update B := B*Q'
+*
+      CALL ZUNMRQ( 'Right', 'Conjugate Transpose', P, N, MIN( M, N ),
+     $             A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
+     $             LWORK, INFO )
+      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+*     QR factorization of P-by-N matrix B: B = Z*T
+*
+      CALL ZGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
+      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+      RETURN
+*
+*     End of ZGGRQF
+*
+      END
diff --git a/SRC/zggsvd.f b/SRC/zggsvd.f
new file mode 100644
index 00000000..8f085c90
--- /dev/null
+++ b/SRC/zggsvd.f
@@ -0,0 +1,333 @@
+      SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
+     $                   LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK,
+     $                   RWORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   ALPHA( * ), BETA( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGSVD computes the generalized singular value decomposition (GSVD)
+*  of an M-by-N complex matrix A and P-by-N complex matrix B:
+*
+*        U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )
+*
+*  where U, V and Q are unitary matrices, and Z' means the conjugate
+*  transpose of Z.  Let K+L = the effective numerical rank of the
+*  matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper
+*  triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal"
+*  matrices and of the following structures, respectively:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                    K  L
+*         D2 =   L ( 0  S )
+*              P-L ( 0  0 )
+*
+*                  N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 )
+*              L (  0    0   R22 )
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                    K M-K K+L-M
+*         D1 =   K ( I  0    0   )
+*              M-K ( 0  C    0   )
+*
+*                      K M-K K+L-M
+*         D2 =   M-K ( 0  S    0  )
+*              K+L-M ( 0  0    I  )
+*                P-L ( 0  0    0  )
+*
+*                     N-K-L  K   M-K  K+L-M
+*    ( 0 R ) =     K ( 0    R11  R12  R13  )
+*                M-K ( 0     0   R22  R23  )
+*              K+L-M ( 0     0    0   R33  )
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*    S = diag( BETA(K+1),  ... , BETA(M) ),
+*    C**2 + S**2 = I.
+*
+*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
+*    ( 0  R22 R23 )
+*    in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The routine computes C, S, R, and optionally the unitary
+*  transformation matrices U, V and Q.
+*
+*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
+*  A and B implicitly gives the SVD of A*inv(B):
+*                       A*inv(B) = U*(D1*inv(D2))*V'.
+*  If ( A',B')' has orthnormal columns, then the GSVD of A and B is also
+*  equal to the CS decomposition of A and B. Furthermore, the GSVD can
+*  be used to derive the solution of the eigenvalue problem:
+*                       A'*A x = lambda* B'*B x.
+*  In some literature, the GSVD of A and B is presented in the form
+*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )
+*  where U and V are orthogonal and X is nonsingular, and D1 and D2 are
+*  ``diagonal''.  The former GSVD form can be converted to the latter
+*  form by taking the nonsingular matrix X as
+*
+*                        X = Q*(  I   0    )
+*                              (  0 inv(R) )
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Unitary matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Unitary matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Unitary matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in Purpose.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular matrix R, or part of R.
+*          See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains part of the triangular matrix R if
+*          M-K-L < 0.  See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = C,
+*            BETA(K+1:K+L)  = S,
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1
+*          and
+*            ALPHA(K+L+1:N) = 0
+*            BETA(K+L+1:N)  = 0
+*
+*  U       (output) COMPLEX*16 array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the M-by-M unitary matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) COMPLEX*16 array, dimension (LDV,P)
+*          If JOBV = 'V', V contains the P-by-P unitary matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) COMPLEX*16 array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (N)
+*          On exit, IWORK stores the sorting information. More
+*          precisely, the following loop will sort ALPHA
+*             for I = K+1, min(M,K+L)
+*                 swap ALPHA(I) and ALPHA(IWORK(I))
+*             endfor
+*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, the Jacobi-type procedure failed to
+*                converge.  For further details, see subroutine ZTGSJA.
+*
+*  Internal Parameters
+*  ===================
+*
+*  TOLA    DOUBLE PRECISION
+*  TOLB    DOUBLE PRECISION
+*          TOLA and TOLB are the thresholds to determine the effective
+*          rank of (A',B')'. Generally, they are set to
+*                   TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+*                   TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  Further Details
+*  ===============
+*
+*  2-96 Based on modifications by
+*     Ming Gu and Huan Ren, Computer Science Division, University of
+*     California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            WANTQ, WANTU, WANTV
+      INTEGER            I, IBND, ISUB, J, NCYCLE
+      DOUBLE PRECISION   ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, DLAMCH, ZLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, XERBLA, ZGGSVP, ZTGSJA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGSVD', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Frobenius norm of matrices A and B
+*
+      ANORM = ZLANGE( '1', M, N, A, LDA, RWORK )
+      BNORM = ZLANGE( '1', P, N, B, LDB, RWORK )
+*
+*     Get machine precision and set up threshold for determining
+*     the effective numerical rank of the matrices A and B.
+*
+      ULP = DLAMCH( 'Precision' )
+      UNFL = DLAMCH( 'Safe Minimum' )
+      TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
+      TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
+*
+      CALL ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
+     $             TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK,
+     $             WORK, WORK( N+1 ), INFO )
+*
+*     Compute the GSVD of two upper "triangular" matrices
+*
+      CALL ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB,
+     $             TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
+     $             WORK, NCYCLE, INFO )
+*
+*     Sort the singular values and store the pivot indices in IWORK
+*     Copy ALPHA to RWORK, then sort ALPHA in RWORK
+*
+      CALL DCOPY( N, ALPHA, 1, RWORK, 1 )
+      IBND = MIN( L, M-K )
+      DO 20 I = 1, IBND
+*
+*        Scan for largest ALPHA(K+I)
+*
+         ISUB = I
+         SMAX = RWORK( K+I )
+         DO 10 J = I + 1, IBND
+            TEMP = RWORK( K+J )
+            IF( TEMP.GT.SMAX ) THEN
+               ISUB = J
+               SMAX = TEMP
+            END IF
+   10    CONTINUE
+         IF( ISUB.NE.I ) THEN
+            RWORK( K+ISUB ) = RWORK( K+I )
+            RWORK( K+I ) = SMAX
+            IWORK( K+I ) = K + ISUB
+         ELSE
+            IWORK( K+I ) = K + I
+         END IF
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of ZGGSVD
+*
+      END
diff --git a/SRC/zggsvp.f b/SRC/zggsvp.f
new file mode 100644
index 00000000..1f61b7ff
--- /dev/null
+++ b/SRC/zggsvp.f
@@ -0,0 +1,402 @@
+      SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
+     $                   TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ,
+     $                   IWORK, RWORK, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+      DOUBLE PRECISION   TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGSVP computes unitary matrices U, V and Q such that
+*
+*                   N-K-L  K    L
+*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
+*                L ( 0     0   A23 )
+*            M-K-L ( 0     0    0  )
+*
+*                   N-K-L  K    L
+*          =     K ( 0    A12  A13 )  if M-K-L < 0;
+*              M-K ( 0     0   A23 )
+*
+*                 N-K-L  K    L
+*   V'*B*Q =   L ( 0     0   B13 )
+*            P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
+*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the
+*  conjugate transpose of Z.
+*
+*  This decomposition is the preprocessing step for computing the
+*  Generalized Singular Value Decomposition (GSVD), see subroutine
+*  ZGGSVD.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  Unitary matrix U is computed;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  Unitary matrix V is computed;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Unitary matrix Q is computed;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A contains the triangular (or trapezoidal) matrix
+*          described in the Purpose section.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, B contains the triangular matrix described in
+*          the Purpose section.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) DOUBLE PRECISION
+*  TOLB    (input) DOUBLE PRECISION
+*          TOLA and TOLB are the thresholds to determine the effective
+*          numerical rank of matrix B and a subblock of A. Generally,
+*          they are set to
+*             TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+*             TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+*          The size of TOLA and TOLB may affect the size of backward
+*          errors of the decomposition.
+*
+*  K       (output) INTEGER
+*  L       (output) INTEGER
+*          On exit, K and L specify the dimension of the subblocks
+*          described in Purpose section.
+*          K + L = effective numerical rank of (A',B')'.
+*
+*  U       (output) COMPLEX*16 array, dimension (LDU,M)
+*          If JOBU = 'U', U contains the unitary matrix U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (output) COMPLEX*16 array, dimension (LDV,M)
+*          If JOBV = 'V', V contains the unitary matrix V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (output) COMPLEX*16 array, dimension (LDQ,N)
+*          If JOBQ = 'Q', Q contains the unitary matrix Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  TAU     (workspace) COMPLEX*16 array, dimension (N)
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization
+*  with column pivoting to detect the effective numerical rank of the
+*  a matrix. It may be replaced by a better rank determination strategy.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FORWRD, WANTQ, WANTU, WANTV
+      INTEGER            I, J
+      COMPLEX*16         T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQPF, ZGEQR2, ZGERQ2, ZLACPY, ZLAPMT,
+     $                   ZLASET, ZUNG2R, ZUNM2R, ZUNMR2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( T ) = ABS( DBLE( T ) ) + ABS( DIMAG( T ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTU = LSAME( JOBU, 'U' )
+      WANTV = LSAME( JOBV, 'V' )
+      WANTQ = LSAME( JOBQ, 'Q' )
+      FORWRD = .TRUE.
+*
+      INFO = 0
+      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -10
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -16
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -18
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGSVP', -INFO )
+         RETURN
+      END IF
+*
+*     QR with column pivoting of B: B*P = V*( S11 S12 )
+*                                           (  0   0  )
+*
+      DO 10 I = 1, N
+         IWORK( I ) = 0
+   10 CONTINUE
+      CALL ZGEQPF( P, N, B, LDB, IWORK, TAU, WORK, RWORK, INFO )
+*
+*     Update A := A*P
+*
+      CALL ZLAPMT( FORWRD, M, N, A, LDA, IWORK )
+*
+*     Determine the effective rank of matrix B.
+*
+      L = 0
+      DO 20 I = 1, MIN( P, N )
+         IF( CABS1( B( I, I ) ).GT.TOLB )
+     $      L = L + 1
+   20 CONTINUE
+*
+      IF( WANTV ) THEN
+*
+*        Copy the details of V, and form V.
+*
+         CALL ZLASET( 'Full', P, P, CZERO, CZERO, V, LDV )
+         IF( P.GT.1 )
+     $      CALL ZLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
+     $                   LDV )
+         CALL ZUNG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
+      END IF
+*
+*     Clean up B
+*
+      DO 40 J = 1, L - 1
+         DO 30 I = J + 1, L
+            B( I, J ) = CZERO
+   30    CONTINUE
+   40 CONTINUE
+      IF( P.GT.L )
+     $   CALL ZLASET( 'Full', P-L, N, CZERO, CZERO, B( L+1, 1 ), LDB )
+*
+      IF( WANTQ ) THEN
+*
+*        Set Q = I and Update Q := Q*P
+*
+         CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+         CALL ZLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
+      END IF
+*
+      IF( P.GE.L .AND. N.NE.L ) THEN
+*
+*        RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z
+*
+         CALL ZGERQ2( L, N, B, LDB, TAU, WORK, INFO )
+*
+*        Update A := A*Z'
+*
+         CALL ZUNMR2( 'Right', 'Conjugate transpose', M, N, L, B, LDB,
+     $                TAU, A, LDA, WORK, INFO )
+         IF( WANTQ ) THEN
+*
+*           Update Q := Q*Z'
+*
+            CALL ZUNMR2( 'Right', 'Conjugate transpose', N, N, L, B,
+     $                   LDB, TAU, Q, LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up B
+*
+         CALL ZLASET( 'Full', L, N-L, CZERO, CZERO, B, LDB )
+         DO 60 J = N - L + 1, N
+            DO 50 I = J - N + L + 1, L
+               B( I, J ) = CZERO
+   50       CONTINUE
+   60    CONTINUE
+*
+      END IF
+*
+*     Let              N-L     L
+*                A = ( A11    A12 ) M,
+*
+*     then the following does the complete QR decomposition of A11:
+*
+*              A11 = U*(  0  T12 )*P1'
+*                      (  0   0  )
+*
+      DO 70 I = 1, N - L
+         IWORK( I ) = 0
+   70 CONTINUE
+      CALL ZGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, RWORK, INFO )
+*
+*     Determine the effective rank of A11
+*
+      K = 0
+      DO 80 I = 1, MIN( M, N-L )
+         IF( CABS1( A( I, I ) ).GT.TOLA )
+     $      K = K + 1
+   80 CONTINUE
+*
+*     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
+*
+      CALL ZUNM2R( 'Left', 'Conjugate transpose', M, L, MIN( M, N-L ),
+     $             A, LDA, TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
+*
+      IF( WANTU ) THEN
+*
+*        Copy the details of U, and form U
+*
+         CALL ZLASET( 'Full', M, M, CZERO, CZERO, U, LDU )
+         IF( M.GT.1 )
+     $      CALL ZLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
+     $                   LDU )
+         CALL ZUNG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
+      END IF
+*
+      IF( WANTQ ) THEN
+*
+*        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1
+*
+         CALL ZLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
+      END IF
+*
+*     Clean up A: set the strictly lower triangular part of
+*     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
+*
+      DO 100 J = 1, K - 1
+         DO 90 I = J + 1, K
+            A( I, J ) = CZERO
+   90    CONTINUE
+  100 CONTINUE
+      IF( M.GT.K )
+     $   CALL ZLASET( 'Full', M-K, N-L, CZERO, CZERO, A( K+1, 1 ), LDA )
+*
+      IF( N-L.GT.K ) THEN
+*
+*        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
+*
+         CALL ZGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
+*
+         IF( WANTQ ) THEN
+*
+*           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
+*
+            CALL ZUNMR2( 'Right', 'Conjugate transpose', N, N-L, K, A,
+     $                   LDA, TAU, Q, LDQ, WORK, INFO )
+         END IF
+*
+*        Clean up A
+*
+         CALL ZLASET( 'Full', K, N-L-K, CZERO, CZERO, A, LDA )
+         DO 120 J = N - L - K + 1, N - L
+            DO 110 I = J - N + L + K + 1, K
+               A( I, J ) = CZERO
+  110       CONTINUE
+  120    CONTINUE
+*
+      END IF
+*
+      IF( M.GT.K ) THEN
+*
+*        QR factorization of A( K+1:M,N-L+1:N )
+*
+         CALL ZGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
+*
+         IF( WANTU ) THEN
+*
+*           Update U(:,K+1:M) := U(:,K+1:M)*U1
+*
+            CALL ZUNM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
+     $                   A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
+     $                   WORK, INFO )
+         END IF
+*
+*        Clean up
+*
+         DO 140 J = N - L + 1, N
+            DO 130 I = J - N + K + L + 1, M
+               A( I, J ) = CZERO
+  130       CONTINUE
+  140    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of ZGGSVP
+*
+      END
diff --git a/SRC/zgtcon.f b/SRC/zgtcon.f
new file mode 100644
index 00000000..43a3a873
--- /dev/null
+++ b/SRC/zgtcon.f
@@ -0,0 +1,171 @@
+      SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
+     $                   WORK, 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, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTCON estimates the reciprocal of the condition number of a complex
+*  tridiagonal matrix A using the LU factorization as computed by
+*  ZGTTRF.
+*
+*  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
+*  =========
+*
+*  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.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by ZGTTRF.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) COMPLEX*16 array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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/(ANORM * AINVNM), where AINVNM is an
+*          estimate of the 1-norm of inv(A) computed in this routine.
+*
+*  WORK    (workspace) COMPLEX*16 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
+      INTEGER            I, KASE, KASE1
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGTTRS, ZLACN2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCMPLX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is non-zero.
+*
+      DO 10 I = 1, N
+         IF( D( I ).EQ.DCMPLX( ZERO ) )
+     $      RETURN
+   10 CONTINUE
+*
+      AINVNM = ZERO
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KASE = 0
+   20 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(U)*inv(L).
+*
+            CALL ZGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
+     $                   WORK, N, INFO )
+         ELSE
+*
+*           Multiply by inv(L')*inv(U').
+*
+            CALL ZGTTRS( 'Conjugate transpose', N, 1, DL, D, DU, DU2,
+     $                   IPIV, WORK, N, INFO )
+         END IF
+         GO TO 20
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of ZGTCON
+*
+      END
diff --git a/SRC/zgtrfs.f b/SRC/zgtrfs.f
new file mode 100644
index 00000000..0eaa02a7
--- /dev/null
+++ b/SRC/zgtrfs.f
@@ -0,0 +1,373 @@
+      SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
+     $                   IPIV, B, LDB, X, LDX, FERR, BERR, 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          TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         B( LDB, * ), D( * ), DF( * ), DL( * ),
+     $                   DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is tridiagonal, and provides
+*  error bounds and backward error estimates for the solution.
+*
+*  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.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A as computed by ZGTTRF.
+*
+*  DF      (input) COMPLEX*16 array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DUF     (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input) COMPLEX*16 array, dimension (N-2)
+*          The (n-2) elements of the second superdiagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZGTTRS.
+*          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) 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
+*
+*  Internal Parameters
+*  ===================
+*
+*  ITMAX is the maximum number of steps of iterative refinement.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANSN, TRANST
+      INTEGER            COUNT, I, J, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGTTRS, ZLACN2, ZLAGTM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -15
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 110 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
+     $                WORK, N )
+*
+*        Compute abs(op(A))*abs(x) + abs(b) for use in the backward
+*        error bound.
+*
+         IF( NOTRAN ) THEN
+            IF( N.EQ.1 ) THEN
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) )
+            ELSE
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
+     $                      CABS1( DU( 1 ) )*CABS1( X( 2, J ) )
+               DO 30 I = 2, N - 1
+                  RWORK( I ) = CABS1( B( I, J ) ) +
+     $                         CABS1( DL( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( D( I ) )*CABS1( X( I, J ) ) +
+     $                         CABS1( DU( I ) )*CABS1( X( I+1, J ) )
+   30          CONTINUE
+               RWORK( N ) = CABS1( B( N, J ) ) +
+     $                      CABS1( DL( N-1 ) )*CABS1( X( N-1, J ) ) +
+     $                      CABS1( D( N ) )*CABS1( X( N, J ) )
+            END IF
+         ELSE
+            IF( N.EQ.1 ) THEN
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) )
+            ELSE
+               RWORK( 1 ) = CABS1( B( 1, J ) ) +
+     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
+     $                      CABS1( DL( 1 ) )*CABS1( X( 2, J ) )
+               DO 40 I = 2, N - 1
+                  RWORK( I ) = CABS1( B( I, J ) ) +
+     $                         CABS1( DU( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( D( I ) )*CABS1( X( I, J ) ) +
+     $                         CABS1( DL( I ) )*CABS1( X( I+1, J ) )
+   40          CONTINUE
+               RWORK( N ) = CABS1( B( N, J ) ) +
+     $                      CABS1( DU( N-1 ) )*CABS1( X( N-1, J ) ) +
+     $                      CABS1( D( N ) )*CABS1( X( N, J ) )
+            END IF
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 50 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+   50    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL ZGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, WORK, N,
+     $                   INFO )
+            CALL ZAXPY( N, DCMPLX( ONE ), WORK, 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 ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 60 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   60    CONTINUE
+*
+         KASE = 0
+   70    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL ZGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
+     $                      N, INFO )
+               DO 80 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+   80          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 90 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+   90          CONTINUE
+               CALL ZGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
+     $                      N, INFO )
+            END IF
+            GO TO 70
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 100 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  100    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of ZGTRFS
+*
+      END
diff --git a/SRC/zgtsv.f b/SRC/zgtsv.f
new file mode 100644
index 00000000..ea466b38
--- /dev/null
+++ b/SRC/zgtsv.f
@@ -0,0 +1,173 @@
+      SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         B( LDB, * ), D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTSV  solves the equation
+*
+*     A*X = B,
+*
+*  where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
+*  partial pivoting.
+*
+*  Note that the equation  A'*X = B  may be solved by interchanging the
+*  order of the arguments DU and DL.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  DL      (input/output) COMPLEX*16 array, dimension (N-1)
+*          On entry, DL must contain the (n-1) subdiagonal elements of
+*          A.
+*          On exit, DL is overwritten by the (n-2) elements of the
+*          second superdiagonal of the upper triangular matrix U from
+*          the LU factorization of A, in DL(1), ..., DL(n-2).
+*
+*  D       (input/output) COMPLEX*16 array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*          On exit, D is overwritten by the n diagonal elements of U.
+*
+*  DU      (input/output) COMPLEX*16 array, dimension (N-1)
+*          On entry, DU must contain the (n-1) superdiagonal elements
+*          of A.
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          superdiagonal of U.
+*
+*  B       (input/output) COMPLEX*16 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).
+*
+*  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, and the solution
+*                has not been computed.  The factorization has not been
+*                completed unless i = N.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, K
+      COMPLEX*16         MULT, TEMP, ZDUM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGTSV ', -INFO )
+         RETURN
+      END IF
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      DO 30 K = 1, N - 1
+         IF( DL( K ).EQ.ZERO ) THEN
+*
+*           Subdiagonal is zero, no elimination is required.
+*
+            IF( D( K ).EQ.ZERO ) THEN
+*
+*              Diagonal is zero: set INFO = K and return; a unique
+*              solution can not be found.
+*
+               INFO = K
+               RETURN
+            END IF
+         ELSE IF( CABS1( D( K ) ).GE.CABS1( DL( K ) ) ) THEN
+*
+*           No row interchange required
+*
+            MULT = DL( K ) / D( K )
+            D( K+1 ) = D( K+1 ) - MULT*DU( K )
+            DO 10 J = 1, NRHS
+               B( K+1, J ) = B( K+1, J ) - MULT*B( K, J )
+   10       CONTINUE
+            IF( K.LT.( N-1 ) )
+     $         DL( K ) = ZERO
+         ELSE
+*
+*           Interchange rows K and K+1
+*
+            MULT = D( K ) / DL( K )
+            D( K ) = DL( K )
+            TEMP = D( K+1 )
+            D( K+1 ) = DU( K ) - MULT*TEMP
+            IF( K.LT.( N-1 ) ) THEN
+               DL( K ) = DU( K+1 )
+               DU( K+1 ) = -MULT*DL( K )
+            END IF
+            DU( K ) = TEMP
+            DO 20 J = 1, NRHS
+               TEMP = B( K, J )
+               B( K, J ) = B( K+1, J )
+               B( K+1, J ) = TEMP - MULT*B( K+1, J )
+   20       CONTINUE
+         END IF
+   30 CONTINUE
+      IF( D( N ).EQ.ZERO ) THEN
+         INFO = N
+         RETURN
+      END IF
+*
+*     Back solve with the matrix U from the factorization.
+*
+      DO 50 J = 1, NRHS
+         B( N, J ) = B( N, J ) / D( N )
+         IF( N.GT.1 )
+     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
+         DO 40 K = N - 2, 1, -1
+            B( K, J ) = ( B( K, J )-DU( K )*B( K+1, J )-DL( K )*
+     $                  B( K+2, J ) ) / D( K )
+   40    CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of ZGTSV
+*
+      END
diff --git a/SRC/zgtsvx.f b/SRC/zgtsvx.f
new file mode 100644
index 00000000..6ecebb07
--- /dev/null
+++ b/SRC/zgtsvx.f
@@ -0,0 +1,292 @@
+      SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
+     $                   DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, TRANS
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         B( LDB, * ), D( * ), DF( * ), DL( * ),
+     $                   DLF( * ), DU( * ), DU2( * ), DUF( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTSVX uses the LU factorization to compute the solution to a complex
+*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A
+*     as A = L * U, where L is a product of permutation and unit lower
+*     bidiagonal matrices and U is upper triangular with nonzeros in
+*     only the main diagonal and first two superdiagonals.
+*
+*  2. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored form
+*                  of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not
+*                  be modified.
+*          = 'N':  The matrix will be copied to DLF, DF, and DUF
+*                  and factored.
+*
+*  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.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) subdiagonal elements of A.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The n diagonal elements of A.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) superdiagonal elements of A.
+*
+*  DLF     (input or output) COMPLEX*16 array, dimension (N-1)
+*          If FACT = 'F', then DLF is an input argument and on entry
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A as computed by ZGTTRF.
+*
+*          If FACT = 'N', then DLF is an output argument and on exit
+*          contains the (n-1) multipliers that define the matrix L from
+*          the LU factorization of A.
+*
+*  DF      (input or output) COMPLEX*16 array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the upper triangular
+*          matrix U from the LU factorization of A.
+*
+*  DUF     (input or output) COMPLEX*16 array, dimension (N-1)
+*          If FACT = 'F', then DUF is an input argument and on entry
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*          If FACT = 'N', then DUF is an output argument and on exit
+*          contains the (n-1) elements of the first superdiagonal of U.
+*
+*  DU2     (input or output) COMPLEX*16 array, dimension (N-2)
+*          If FACT = 'F', then DU2 is an input argument and on entry
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*          If FACT = 'N', then DU2 is an output argument and on exit
+*          contains the (n-2) elements of the second superdiagonal of
+*          U.
+*
+*  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 LU factorization of A as
+*          computed by ZGTTRF.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the LU factorization of A;
+*          row i of the matrix was interchanged with row IPIV(i).
+*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
+*          a row interchange was not required.
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  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.  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  U(i,i) is exactly zero.  The factorization
+*                       has not been completed unless i = N, but the
+*                       factor U is exactly singular, so the solution
+*                       and error bounds could not be computed.
+*                       RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT, NOTRAN
+      CHARACTER          NORM
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANGT
+      EXTERNAL           LSAME, DLAMCH, ZLANGT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZGTCON, ZGTRFS, ZGTTRF, ZGTTRS,
+     $                   ZLACPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -14
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the LU factorization of A.
+*
+         CALL ZCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 ) THEN
+            CALL ZCOPY( N-1, DL, 1, DLF, 1 )
+            CALL ZCOPY( N-1, DU, 1, DUF, 1 )
+         END IF
+         CALL ZGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = ZLANGT( NORM, N, DL, D, DU )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
+     $             INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
+     $             INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
+     $             B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZGTSVX
+*
+      END
diff --git a/SRC/zgttrf.f b/SRC/zgttrf.f
new file mode 100644
index 00000000..2d2c1aa6
--- /dev/null
+++ b/SRC/zgttrf.f
@@ -0,0 +1,174 @@
+      SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, 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 ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTTRF computes an LU factorization of a complex tridiagonal matrix A
+*  using elimination with partial pivoting and row interchanges.
+*
+*  The factorization has the form
+*     A = L * U
+*  where L is a product of permutation and unit lower bidiagonal
+*  matrices and U is upper triangular with nonzeros in only the main
+*  diagonal and first two superdiagonals.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  DL      (input/output) COMPLEX*16 array, dimension (N-1)
+*          On entry, DL must contain the (n-1) sub-diagonal elements of
+*          A.
+*
+*          On exit, DL is overwritten by the (n-1) multipliers that
+*          define the matrix L from the LU factorization of A.
+*
+*  D       (input/output) COMPLEX*16 array, dimension (N)
+*          On entry, D must contain the diagonal elements of A.
+*
+*          On exit, D is overwritten by the n diagonal elements of the
+*          upper triangular matrix U from the LU factorization of A.
+*
+*  DU      (input/output) COMPLEX*16 array, dimension (N-1)
+*          On entry, DU must contain the (n-1) super-diagonal elements
+*          of A.
+*
+*          On exit, DU is overwritten by the (n-1) elements of the first
+*          super-diagonal of U.
+*
+*  DU2     (output) COMPLEX*16 array, dimension (N-2)
+*          On exit, DU2 is overwritten by the (n-2) elements of the
+*          second super-diagonal of U.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  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   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16         FACT, TEMP, ZDUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'ZGTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize IPIV(i) = i and DU2(i) = 0
+*
+      DO 10 I = 1, N
+         IPIV( I ) = I
+   10 CONTINUE
+      DO 20 I = 1, N - 2
+         DU2( I ) = ZERO
+   20 CONTINUE
+*
+      DO 30 I = 1, N - 2
+         IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
+*
+*           No row interchange required, eliminate DL(I)
+*
+            IF( CABS1( D( I ) ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+*
+*           Interchange rows I and I+1, eliminate DL(I)
+*
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            DU2( I ) = DU( I+1 )
+            DU( I+1 ) = -FACT*DU( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+   30 CONTINUE
+      IF( N.GT.1 ) THEN
+         I = N - 1
+         IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
+            IF( CABS1( D( I ) ).NE.ZERO ) THEN
+               FACT = DL( I ) / D( I )
+               DL( I ) = FACT
+               D( I+1 ) = D( I+1 ) - FACT*DU( I )
+            END IF
+         ELSE
+            FACT = D( I ) / DL( I )
+            D( I ) = DL( I )
+            DL( I ) = FACT
+            TEMP = DU( I )
+            DU( I ) = D( I+1 )
+            D( I+1 ) = TEMP - FACT*D( I+1 )
+            IPIV( I ) = I + 1
+         END IF
+      END IF
+*
+*     Check for a zero on the diagonal of U.
+*
+      DO 40 I = 1, N
+         IF( CABS1( D( I ) ).EQ.ZERO ) THEN
+            INFO = I
+            GO TO 50
+         END IF
+   40 CONTINUE
+   50 CONTINUE
+*
+      RETURN
+*
+*     End of ZGTTRF
+*
+      END
diff --git a/SRC/zgttrs.f b/SRC/zgttrs.f
new file mode 100644
index 00000000..60e71f54
--- /dev/null
+++ b/SRC/zgttrs.f
@@ -0,0 +1,142 @@
+      SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTTRS solves one of the systems of equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by ZGTTRF.
+*
+*  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.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) COMPLEX*16 array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            ITRANS, J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGTTS2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
+      IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
+     $    't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Decode TRANS
+*
+      IF( NOTRAN ) THEN
+         ITRANS = 0
+      ELSE IF( TRANS.EQ.'T' .OR. TRANS.EQ.'t' ) THEN
+         ITRANS = 1
+      ELSE
+         ITRANS = 2
+      END IF
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'ZGTTRS', TRANS, N, NRHS, -1, -1 ) )
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL ZGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
+     $                   LDB )
+   10    CONTINUE
+      END IF
+*
+*     End of ZGTTRS
+*
+      END
diff --git a/SRC/zgtts2.f b/SRC/zgtts2.f
new file mode 100644
index 00000000..da6073d8
--- /dev/null
+++ b/SRC/zgtts2.f
@@ -0,0 +1,271 @@
+      SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ITRANS, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGTTS2 solves one of the systems of equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*  with a tridiagonal matrix A using the LU factorization computed
+*  by ZGTTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITRANS  (input) INTEGER
+*          Specifies the form of the system of equations.
+*          = 0:  A * X = B     (No transpose)
+*          = 1:  A**T * X = B  (Transpose)
+*          = 2:  A**H * X = B  (Conjugate transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) multipliers that define the matrix L from the
+*          LU factorization of A.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The n diagonal elements of the upper triangular matrix U from
+*          the LU factorization of A.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) elements of the first super-diagonal of U.
+*
+*  DU2     (input) COMPLEX*16 array, dimension (N-2)
+*          The (n-2) elements of the second super-diagonal of U.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices; for 1 <= i <= n, row i of the matrix was
+*          interchanged with row IPIV(i).  IPIV(i) will always be either
+*          i or i+1; IPIV(i) = i indicates a row interchange was not
+*          required.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the matrix of right hand side vectors B.
+*          On exit, B is overwritten by the solution vectors X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+      COMPLEX*16         TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( ITRANS.EQ.0 ) THEN
+*
+*        Solve A*X = B using the LU factorization of A,
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+   10       CONTINUE
+*
+*           Solve L*x = b.
+*
+            DO 20 I = 1, N - 1
+               IF( IPIV( I ).EQ.I ) THEN
+                  B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+               ELSE
+                  TEMP = B( I, J )
+                  B( I, J ) = B( I+1, J )
+                  B( I+1, J ) = TEMP - DL( I )*B( I, J )
+               END IF
+   20       CONTINUE
+*
+*           Solve U*x = b.
+*
+            B( N, J ) = B( N, J ) / D( N )
+            IF( N.GT.1 )
+     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                       D( N-1 )
+            DO 30 I = N - 2, 1, -1
+               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                     B( I+2, J ) ) / D( I )
+   30       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 10
+            END IF
+         ELSE
+            DO 60 J = 1, NRHS
+*
+*           Solve L*x = b.
+*
+               DO 40 I = 1, N - 1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+                  ELSE
+                     TEMP = B( I, J )
+                     B( I, J ) = B( I+1, J )
+                     B( I+1, J ) = TEMP - DL( I )*B( I, J )
+                  END IF
+   40          CONTINUE
+*
+*           Solve U*x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               IF( N.GT.1 )
+     $            B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+     $                          D( N-1 )
+               DO 50 I = N - 2, 1, -1
+                  B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+     $                        B( I+2, J ) ) / D( I )
+   50          CONTINUE
+   60       CONTINUE
+         END IF
+      ELSE IF( ITRANS.EQ.1 ) THEN
+*
+*        Solve A**T * X = B.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+   70       CONTINUE
+*
+*           Solve U**T * x = b.
+*
+            B( 1, J ) = B( 1, J ) / D( 1 )
+            IF( N.GT.1 )
+     $         B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+            DO 80 I = 3, N
+               B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
+     $                     B( I-2, J ) ) / D( I )
+   80       CONTINUE
+*
+*           Solve L**T * x = b.
+*
+            DO 90 I = N - 1, 1, -1
+               IF( IPIV( I ).EQ.I ) THEN
+                  B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+               ELSE
+                  TEMP = B( I+1, J )
+                  B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+                  B( I, J ) = TEMP
+               END IF
+   90       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 70
+            END IF
+         ELSE
+            DO 120 J = 1, NRHS
+*
+*           Solve U**T * x = b.
+*
+               B( 1, J ) = B( 1, J ) / D( 1 )
+               IF( N.GT.1 )
+     $            B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+               DO 100 I = 3, N
+                  B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
+     $                        DU2( I-2 )*B( I-2, J ) ) / D( I )
+  100          CONTINUE
+*
+*           Solve L**T * x = b.
+*
+               DO 110 I = N - 1, 1, -1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+                  ELSE
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+                     B( I, J ) = TEMP
+                  END IF
+  110          CONTINUE
+  120       CONTINUE
+         END IF
+      ELSE
+*
+*        Solve A**H * X = B.
+*
+         IF( NRHS.LE.1 ) THEN
+            J = 1
+  130       CONTINUE
+*
+*           Solve U**H * x = b.
+*
+            B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) )
+            IF( N.GT.1 )
+     $         B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) /
+     $                     DCONJG( D( 2 ) )
+            DO 140 I = 3, N
+               B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )-
+     $                     DCONJG( DU2( I-2 ) )*B( I-2, J ) ) /
+     $                     DCONJG( D( I ) )
+  140       CONTINUE
+*
+*           Solve L**H * x = b.
+*
+            DO 150 I = N - 1, 1, -1
+               IF( IPIV( I ).EQ.I ) THEN
+                  B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J )
+               ELSE
+                  TEMP = B( I+1, J )
+                  B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP
+                  B( I, J ) = TEMP
+               END IF
+  150       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 130
+            END IF
+         ELSE
+            DO 180 J = 1, NRHS
+*
+*           Solve U**H * x = b.
+*
+               B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) )
+               IF( N.GT.1 )
+     $            B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) )
+     $                         / DCONJG( D( 2 ) )
+               DO 160 I = 3, N
+                  B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*
+     $                        B( I-1, J )-DCONJG( DU2( I-2 ) )*
+     $                        B( I-2, J ) ) / DCONJG( D( I ) )
+  160          CONTINUE
+*
+*           Solve L**H * x = b.
+*
+               DO 170 I = N - 1, 1, -1
+                  IF( IPIV( I ).EQ.I ) THEN
+                     B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*
+     $                           B( I+1, J )
+                  ELSE
+                     TEMP = B( I+1, J )
+                     B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP
+                     B( I, J ) = TEMP
+                  END IF
+  170          CONTINUE
+  180       CONTINUE
+         END IF
+      END IF
+*
+*     End of ZGTTS2
+*
+      END
diff --git a/SRC/zhbev.f b/SRC/zhbev.f
new file mode 100644
index 00000000..6bfa26c9
--- /dev/null
+++ b/SRC/zhbev.f
@@ -0,0 +1,208 @@
+      SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+     $                  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, KD, LDAB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AB( LDAB, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBEV computes all the eigenvalues and, optionally, eigenvectors of
+*  a complex Hermitian band 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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 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) COMPLEX*16 array, dimension (N)
+*
+*  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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, ISCALE
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHB
+      EXTERNAL           LSAME, DLAMCH, ZLANHB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTERF, XERBLA, ZHBTRD, ZLASCL, ZSTEQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            W( 1 ) = AB( 1, 1 )
+         ELSE
+            W( 1 ) = AB( KD+1, 1 )
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, 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 ) THEN
+         IF( LOWER ) THEN
+            CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form.
+*
+      INDE = 1
+      CALL ZHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call ZSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         INDRWK = INDE + N
+         CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
+     $                RWORK( INDRWK ), 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 ZHBEV
+*
+      END
diff --git a/SRC/zhbevd.f b/SRC/zhbevd.f
new file mode 100644
index 00000000..a3b2ffe7
--- /dev/null
+++ b/SRC/zhbevd.f
@@ -0,0 +1,302 @@
+      SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+     $                   LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, KD, LDAB, LDZ, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AB( LDAB, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of
+*  a complex Hermitian band matrix A.  If eigenvectors are desired, it
+*  uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the first
+*          superdiagonal and the diagonal of the tridiagonal matrix T
+*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+*          the diagonal and first subdiagonal of T are returned in the
+*          first two rows of AB.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 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/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 N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array,
+*                                         dimension (LRWORK)
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LRWORK must be at least
+*                        1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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 array IWORK.
+*          If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDWK2, INDWRK, ISCALE,
+     $                   LIWMIN, LLRWK, LLWK2, LRWMIN, LWMIN
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHB
+      EXTERNAL           LSAME, DLAMCH, ZLANHB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTERF, XERBLA, ZGEMM, ZHBTRD, ZLACPY,
+     $                   ZLASCL, ZSTEDC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LWMIN = 1
+         LRWMIN = 1
+         LIWMIN = 1
+      ELSE
+         IF( WANTZ ) THEN
+            LWMIN = 2*N**2
+            LRWMIN = 1 + 5*N + 2*N**2
+            LIWMIN = 3 + 5*N
+         ELSE
+            LWMIN = N
+            LRWMIN = N
+            LIWMIN = 1
+         END IF
+      END IF
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AB( 1, 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = 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 = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, 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 ) THEN
+         IF( LOWER ) THEN
+            CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+      END IF
+*
+*     Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = 1 + N*N
+      LLWK2 = LWORK - INDWK2 + 1
+      LLRWK = LRWORK - INDWRK + 1
+      CALL ZHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call ZSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK, N, WORK( INDWK2 ),
+     $                LLWK2, RWORK( INDWRK ), LLRWK, IWORK, LIWORK,
+     $                INFO )
+         CALL ZGEMM( 'N', 'N', N, N, N, CONE, Z, LDZ, WORK, N, CZERO,
+     $               WORK( INDWK2 ), N )
+         CALL ZLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      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
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of ZHBEVD
+*
+      END
diff --git a/SRC/zhbevx.f b/SRC/zhbevx.f
new file mode 100644
index 00000000..78f31661
--- /dev/null
+++ b/SRC/zhbevx.f
@@ -0,0 +1,421 @@
+      SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
+     $                   VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AB( LDAB, * ), Q( LDQ, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian band matrix A.  Eigenvalues and eigenvectors
+*  can be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, AB is overwritten by values generated during the
+*          reduction to tridiagonal form.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD + 1.
+*
+*  Q       (output) COMPLEX*16 array, dimension (LDQ, N)
+*          If JOBZ = 'V', the N-by-N unitary matrix used in the
+*                          reduction to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'V', then
+*          LDQ >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AB to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. 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            ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1,
+     $                   J, JJ, NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+      COMPLEX*16         CTMP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHB
+      EXTERNAL           LSAME, DLAMCH, ZLANHB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZCOPY,
+     $                   ZGEMV, ZHBTRD, ZLACPY, ZLASCL, ZSTEIN, ZSTEQR,
+     $                   ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LOWER = LSAME( UPLO, 'L' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -18
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         M = 1
+         IF( LOWER ) THEN
+            CTMP1 = AB( 1, 1 )
+         ELSE
+            CTMP1 = AB( KD+1, 1 )
+         END IF
+         TMP1 = DBLE( CTMP1 )
+         IF( VALEIG ) THEN
+            IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
+     $         M = 0
+         END IF
+         IF( M.EQ.1 ) THEN
+            W( 1 ) = CTMP1
+            IF( WANTZ )
+     $         Z( 1, 1 ) = CONE
+         END IF
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      END IF
+      ANRM = ZLANHB( 'M', UPLO, N, KD, AB, LDAB, RWORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         ELSE
+            CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDWRK = 1
+      CALL ZHBTRD( JOBZ, UPLO, N, KD, AB, LDAB, RWORK( INDD ),
+     $             RWORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call DSTERF or ZSTEQR.  If this fails for some
+*     eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL DSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL ZLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by ZSTEIN.
+*
+         DO 20 J = 1, M
+            CALL ZCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL ZGEMV( 'N', N, N, CONE, Q, LDQ, WORK, 1, CZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHBEVX
+*
+      END
diff --git a/SRC/zhbgst.f b/SRC/zhbgst.f
new file mode 100644
index 00000000..69685792
--- /dev/null
+++ b/SRC/zhbgst.f
@@ -0,0 +1,1377 @@
+      SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
+     $                   LDX, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO, VECT
+      INTEGER            INFO, KA, KB, LDAB, LDBB, LDX, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBGST reduces a complex Hermitian-definite banded generalized
+*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,
+*  such that C has the same bandwidth as A.
+*
+*  B must have been previously factorized as S**H*S by ZPBSTF, using a
+*  split Cholesky factorization. A is overwritten by C = X**H*A*X, where
+*  X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the
+*  bandwidth of A.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form the transformation matrix X;
+*          = 'V':  form X.
+*
+*  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 matrices A and B.  N >= 0.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the transformed matrix X**H*A*X, stored in the same
+*          format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input) COMPLEX*16 array, dimension (LDBB,N)
+*          The banded factor S from the split Cholesky factorization of
+*          B, as returned by ZPBSTF, stored in the first kb+1 rows of
+*          the array.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,N)
+*          If VECT = 'V', the n-by-n matrix X.
+*          If VECT = 'N', the array X is not referenced.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.
+*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ), ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPDATE, UPPER, WANTX
+      INTEGER            I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
+     $                   KA1, KB1, KBT, L, M, NR, NRT, NX
+      DOUBLE PRECISION   BII
+      COMPLEX*16         RA, RA1, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZGERC, ZGERU, ZLACGV, ZLAR2V,
+     $                   ZLARGV, ZLARTG, ZLARTV, ZLASET, ZROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCONJG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      WANTX = LSAME( VECT, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      KA1 = KA + 1
+      KB1 = KB + 1
+      INFO = 0
+      IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      INCA = LDAB*KA1
+*
+*     Initialize X to the unit matrix, if needed
+*
+      IF( WANTX )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, X, LDX )
+*
+*     Set M to the splitting point m. It must be the same value as is
+*     used in ZPBSTF. The chosen value allows the arrays WORK and RWORK
+*     to be of dimension (N).
+*
+      M = ( N+KB ) / 2
+*
+*     The routine works in two phases, corresponding to the two halves
+*     of the split Cholesky factorization of B as S**H*S where
+*
+*     S = ( U    )
+*         ( M  L )
+*
+*     with U upper triangular of order m, and L lower triangular of
+*     order n-m. S has the same bandwidth as B.
+*
+*     S is treated as a product of elementary matrices:
+*
+*     S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
+*
+*     where S(i) is determined by the i-th row of S.
+*
+*     In phase 1, the index i takes the values n, n-1, ... , m+1;
+*     in phase 2, it takes the values 1, 2, ... , m.
+*
+*     For each value of i, the current matrix A is updated by forming
+*     inv(S(i))**H*A*inv(S(i)). This creates a triangular bulge outside
+*     the band of A. The bulge is then pushed down toward the bottom of
+*     A in phase 1, and up toward the top of A in phase 2, by applying
+*     plane rotations.
+*
+*     There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
+*     of them are linearly independent, so annihilating a bulge requires
+*     only 2*kb-1 plane rotations. The rotations are divided into a 1st
+*     set of kb-1 rotations, and a 2nd set of kb rotations.
+*
+*     Wherever possible, rotations are generated and applied in vector
+*     operations of length NR between the indices J1 and J2 (sometimes
+*     replaced by modified values NRT, J1T or J2T).
+*
+*     The real cosines and complex sines of the rotations are stored in
+*     the arrays RWORK and WORK, those of the 1st set in elements
+*     2:m-kb-1, and those of the 2nd set in elements m-kb+1:n.
+*
+*     The bulges are not formed explicitly; nonzero elements outside the
+*     band are created only when they are required for generating new
+*     rotations; they are stored in the array WORK, in positions where
+*     they are later overwritten by the sines of the rotations which
+*     annihilate them.
+*
+*     **************************** Phase 1 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = N, M + 1, -1
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M + KA + 1, N - 1
+*        apply rotations to push all bulges KA positions downward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = N + 1
+   10 CONTINUE
+      IF( UPDATE ) THEN
+         I = I - 1
+         KBT = MIN( KB, I-1 )
+         I0 = I - 1
+         I1 = MIN( N, I+KA )
+         I2 = I - KBT + KA1
+         IF( I.LT.M+1 ) THEN
+            UPDATE = .FALSE.
+            I = I + 1
+            I0 = M
+            IF( KA.EQ.0 )
+     $         GO TO 480
+            GO TO 10
+         END IF
+      ELSE
+         I = I + KA
+         IF( I.GT.N-1 )
+     $      GO TO 480
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = DBLE( BB( KB1, I ) )
+            AB( KA1, I ) = ( DBLE( AB( KA1, I ) ) / BII ) / BII
+            DO 20 J = I + 1, I1
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+   20       CONTINUE
+            DO 30 J = MAX( 1, I-KA ), I - 1
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+   30       CONTINUE
+            DO 60 K = I - KBT, I - 1
+               DO 40 J = I - KBT, K
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( J-I+KB1, I )*
+     $                               DCONJG( AB( K-I+KA1, I ) ) -
+     $                               DCONJG( BB( K-I+KB1, I ) )*
+     $                               AB( J-I+KA1, I ) +
+     $                               DBLE( AB( KA1, I ) )*
+     $                               BB( J-I+KB1, I )*
+     $                               DCONJG( BB( K-I+KB1, I ) )
+   40          CONTINUE
+               DO 50 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               DCONJG( BB( K-I+KB1, I ) )*
+     $                               AB( J-I+KA1, I )
+   50          CONTINUE
+   60       CONTINUE
+            DO 80 J = I, I1
+               DO 70 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( K-I+KB1, I )*AB( I-J+KA1, J )
+   70          CONTINUE
+   80       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL ZDSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL ZGERC( N-M, KBT, -CONE, X( M+1, I ), 1,
+     $                        BB( KB1-KBT, I ), 1, X( M+1, I-KBT ),
+     $                        LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+KA1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 130 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i,i-k+ka+1)
+*
+                  CALL ZLARTG( AB( K+1, I-K+KA ), RA1,
+     $                         RWORK( I-K+KA-M ), WORK( I-K+KA-M ), RA )
+*
+*                 create nonzero element a(i-k,i-k+ka+1) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( KB1-K, I )*RA1
+                  WORK( I-K ) = RWORK( I-K+KA-M )*T -
+     $                          DCONJG( WORK( I-K+KA-M ) )*
+     $                          AB( 1, I-K+KA )
+                  AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
+     $                              RWORK( I-K+KA-M )*AB( 1, I-K+KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 90 J = J2T, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
+               AB( 1, J+1 ) = RWORK( J-M )*AB( 1, J+1 )
+   90       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL ZLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
+     $                      RWORK( J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 100 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  100          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, RWORK( J2-M ),
+     $                      WORK( J2-M ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( J2-M ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 110 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  110       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 120 J = J2, J1, KA1
+                  CALL ZROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J-M ), DCONJG( WORK( J-M ) ) )
+  120          CONTINUE
+            END IF
+  130    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt,i-kbt+ka+1) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
+            END IF
+         END IF
+*
+         DO 170 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 140 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J2-L+1 ), INCA,
+     $                         AB( L+1, J2-L+1 ), INCA, RWORK( J2-KA ),
+     $                         WORK( J2-KA ), KA1 )
+  140       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 150 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               RWORK( J ) = RWORK( J-KA )
+  150       CONTINUE
+            DO 160 J = J2, J1, KA1
+*
+*              create nonzero element a(j-ka,j+1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+1 )
+               AB( 1, J+1 ) = RWORK( J )*AB( 1, J+1 )
+  160       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  170    CONTINUE
+*
+         DO 210 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL ZLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
+     $                      RWORK( J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 180 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( KA1-L, J2 ), INCA,
+     $                         AB( KA-L, J2+1 ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  180          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+     $                      AB( KA, J2+1 ), INCA, RWORK( J2 ),
+     $                      WORK( J2 ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( J2 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 190 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  190       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 200 J = J2, J1, KA1
+                  CALL ZROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J ), DCONJG( WORK( J ) ) )
+  200          CONTINUE
+            END IF
+  210    CONTINUE
+*
+         DO 230 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 220 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+     $                         AB( L+1, J2+KA1-L ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  220       CONTINUE
+  230    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 240 J = N - 1, I2 + KA, -1
+               RWORK( J-M ) = RWORK( J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  240       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = DBLE( BB( 1, I ) )
+            AB( 1, I ) = ( DBLE( AB( 1, I ) ) / BII ) / BII
+            DO 250 J = I + 1, I1
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  250       CONTINUE
+            DO 260 J = MAX( 1, I-KA ), I - 1
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  260       CONTINUE
+            DO 290 K = I - KBT, I - 1
+               DO 270 J = I - KBT, K
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( I-J+1, J )*DCONJG( AB( I-K+1,
+     $                             K ) ) - DCONJG( BB( I-K+1, K ) )*
+     $                             AB( I-J+1, J ) + DBLE( AB( 1, I ) )*
+     $                             BB( I-J+1, J )*DCONJG( BB( I-K+1,
+     $                             K ) )
+  270          CONTINUE
+               DO 280 J = MAX( 1, I-KA ), I - KBT - 1
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             DCONJG( BB( I-K+1, K ) )*
+     $                             AB( I-J+1, J )
+  280          CONTINUE
+  290       CONTINUE
+            DO 310 J = I, I1
+               DO 300 K = MAX( J-KA, I-KBT ), I - 1
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( I-K+1, K )*AB( J-I+1, I )
+  300          CONTINUE
+  310       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL ZDSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL ZGERU( N-M, KBT, -CONE, X( M+1, I ), 1,
+     $                        BB( KBT+1, I-KBT ), LDBB-1,
+     $                        X( M+1, I-KBT ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions down toward the bottom of the
+*        band
+*
+         DO 360 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+*                 generate rotation to annihilate a(i-k+ka+1,i)
+*
+                  CALL ZLARTG( AB( KA1-K, I ), RA1, RWORK( I-K+KA-M ),
+     $                         WORK( I-K+KA-M ), RA )
+*
+*                 create nonzero element a(i-k+ka+1,i-k) outside the
+*                 band and store it in WORK(i-k)
+*
+                  T = -BB( K+1, I-K )*RA1
+                  WORK( I-K ) = RWORK( I-K+KA-M )*T -
+     $                          DCONJG( WORK( I-K+KA-M ) )*
+     $                          AB( KA1, I-K )
+                  AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
+     $                             RWORK( I-K+KA-M )*AB( KA1, I-K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MAX( J2, I+2*KA-K+1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( N-J2T+KA ) / KA1
+            DO 320 J = J2T, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j-m)
+*
+               WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = RWORK( J-M )*AB( KA1, J-KA+1 )
+  320       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL ZLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
+     $                      KA1, RWORK( J2T-M ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 330 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  330          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, RWORK( J2-M ), WORK( J2-M ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( J2-M ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 340 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  340       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 350 J = J2, J1, KA1
+                  CALL ZROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J-M ), WORK( J-M ) )
+  350          CONTINUE
+            END IF
+  360    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i-kbt+ka+1,i-kbt) outside the
+*              band and store it in WORK(i-kbt)
+*
+               WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
+            END IF
+         END IF
+*
+         DO 400 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+            ELSE
+               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 370 L = KB - K, 1, -1
+               NRT = ( N-J2+KA+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
+     $                         AB( KA1-L, J2-KA+1 ), INCA,
+     $                         RWORK( J2-KA ), WORK( J2-KA ), KA1 )
+  370       CONTINUE
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            DO 380 J = J1, J2, -KA1
+               WORK( J ) = WORK( J-KA )
+               RWORK( J ) = RWORK( J-KA )
+  380       CONTINUE
+            DO 390 J = J2, J1, KA1
+*
+*              create nonzero element a(j+1,j-ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
+               AB( KA1, J-KA+1 ) = RWORK( J )*AB( KA1, J-KA+1 )
+  390       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I-K.LT.N-KA .AND. K.LE.KBT )
+     $            WORK( I-K+KA ) = WORK( I-K )
+            END IF
+  400    CONTINUE
+*
+         DO 440 K = KB, 1, -1
+            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+            NR = ( N-J2+KA ) / KA1
+            J1 = J2 + ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL ZLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
+     $                      RWORK( J2 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 410 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( L+1, J2-L ), INCA,
+     $                         AB( L+2, J2-L ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  410          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+     $                      INCA, RWORK( J2 ), WORK( J2 ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( J2 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 420 L = KA - 1, KB - K + 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, RWORK( J2 ),
+     $                         WORK( J2 ), KA1 )
+  420       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 430 J = J2, J1, KA1
+                  CALL ZROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+     $                       RWORK( J ), WORK( J ) )
+  430          CONTINUE
+            END IF
+  440    CONTINUE
+*
+         DO 460 K = 1, KB - 1
+            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 450 L = KB - K, 1, -1
+               NRT = ( N-J2+L ) / KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+     $                         AB( KA1-L, J2+1 ), INCA, RWORK( J2-M ),
+     $                         WORK( J2-M ), KA1 )
+  450       CONTINUE
+  460    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 470 J = N - 1, I2 + KA, -1
+               RWORK( J-M ) = RWORK( J-KA-M )
+               WORK( J-M ) = WORK( J-KA-M )
+  470       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 10
+*
+  480 CONTINUE
+*
+*     **************************** Phase 2 *****************************
+*
+*     The logical structure of this phase is:
+*
+*     UPDATE = .TRUE.
+*     DO I = 1, M
+*        use S(i) to update A and create a new bulge
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*     UPDATE = .FALSE.
+*     DO I = M - KA - 1, 2, -1
+*        apply rotations to push all bulges KA positions upward
+*     END DO
+*
+*     To avoid duplicating code, the two loops are merged.
+*
+      UPDATE = .TRUE.
+      I = 0
+  490 CONTINUE
+      IF( UPDATE ) THEN
+         I = I + 1
+         KBT = MIN( KB, M-I )
+         I0 = I + 1
+         I1 = MAX( 1, I-KA )
+         I2 = I + KBT - KA1
+         IF( I.GT.M ) THEN
+            UPDATE = .FALSE.
+            I = I - 1
+            I0 = M + 1
+            IF( KA.EQ.0 )
+     $         RETURN
+            GO TO 490
+         END IF
+      ELSE
+         I = I - KA
+         IF( I.LT.2 )
+     $      RETURN
+      END IF
+*
+      IF( I.LT.M-KBT ) THEN
+         NX = M
+      ELSE
+         NX = N
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Transform A, working with the upper triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = DBLE( BB( KB1, I ) )
+            AB( KA1, I ) = ( DBLE( AB( KA1, I ) ) / BII ) / BII
+            DO 500 J = I1, I - 1
+               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+  500       CONTINUE
+            DO 510 J = I + 1, MIN( N, I+KA )
+               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+  510       CONTINUE
+            DO 540 K = I + 1, I + KBT
+               DO 520 J = K, I + KBT
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               BB( I-J+KB1, J )*
+     $                               DCONJG( AB( I-K+KA1, K ) ) -
+     $                               DCONJG( BB( I-K+KB1, K ) )*
+     $                               AB( I-J+KA1, J ) +
+     $                               DBLE( AB( KA1, I ) )*
+     $                               BB( I-J+KB1, J )*
+     $                               DCONJG( BB( I-K+KB1, K ) )
+  520          CONTINUE
+               DO 530 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+     $                               DCONJG( BB( I-K+KB1, K ) )*
+     $                               AB( I-J+KA1, J )
+  530          CONTINUE
+  540       CONTINUE
+            DO 560 J = I1, I
+               DO 550 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+     $                               BB( I-K+KB1, K )*AB( J-I+KA1, I )
+  550          CONTINUE
+  560       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL ZDSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL ZGERU( NX, KBT, -CONE, X( 1, I ), 1,
+     $                        BB( KB, I+1 ), LDBB-1, X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i1,i) in RA1 for use in next loop over K
+*
+            RA1 = AB( I1-I+KA1, I )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 610 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i+k-ka-1,i)
+*
+                  CALL ZLARTG( AB( K+1, I ), RA1, RWORK( I+K-KA ),
+     $                         WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k-ka-1,i+k) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( KB1-K, I+K )*RA1
+                  WORK( M-KB+I+K ) = RWORK( I+K-KA )*T -
+     $                               DCONJG( WORK( I+K-KA ) )*
+     $                               AB( 1, I+K )
+                  AB( 1, I+K ) = WORK( I+K-KA )*T +
+     $                           RWORK( I+K-KA )*AB( 1, I+K )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 570 J = J1, J2T, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = RWORK( J )*AB( 1, J+KA-1 )
+  570       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL ZLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
+     $                      RWORK( J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the left
+*
+               DO 580 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA, RWORK( J1 ),
+     $                         WORK( J1 ), KA1 )
+  580          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, RWORK( J1 ), WORK( J1 ),
+     $                      KA1 )
+*
+               CALL ZLACGV( NR, WORK( J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the right
+*
+            DO 590 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, RWORK( J1T ),
+     $                         WORK( J1T ), KA1 )
+  590       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 600 J = J1, J2, KA1
+                  CALL ZROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( J ), WORK( J ) )
+  600          CONTINUE
+            END IF
+  610    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt-ka-1,i+kbt) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
+            END IF
+         END IF
+*
+         DO 650 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the right
+*
+            DO 620 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J1T+KA ), INCA,
+     $                         AB( L+1, J1T+KA-1 ), INCA,
+     $                         RWORK( M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  620       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 630 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               RWORK( M-KB+J ) = RWORK( M-KB+J+KA )
+  630       CONTINUE
+            DO 640 J = J1, J2, KA1
+*
+*              create nonzero element a(j-1,j+ka) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
+               AB( 1, J+KA-1 ) = RWORK( M-KB+J )*AB( 1, J+KA-1 )
+  640       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  650    CONTINUE
+*
+         DO 690 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL ZLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, RWORK( M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the left
+*
+               DO 660 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( KA1-L, J1+L ), INCA,
+     $                         AB( KA-L, J1+L ), INCA, RWORK( M-KB+J1 ),
+     $                         WORK( M-KB+J1 ), KA1 )
+  660          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+     $                      AB( KA, J1 ), INCA, RWORK( M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( M-KB+J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the right
+*
+            DO 670 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA,
+     $                         RWORK( M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  670       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 680 J = J1, J2, KA1
+                  CALL ZROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( M-KB+J ), WORK( M-KB+J ) )
+  680          CONTINUE
+            END IF
+  690    CONTINUE
+*
+         DO 710 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the right
+*
+            DO 700 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( L, J1T ), INCA,
+     $                         AB( L+1, J1T-1 ), INCA, RWORK( J1T ),
+     $                         WORK( J1T ), KA1 )
+  700       CONTINUE
+  710    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 720 J = 2, I2 - KA
+               RWORK( J ) = RWORK( J+KA )
+               WORK( J ) = WORK( J+KA )
+  720       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Transform A, working with the lower triangle
+*
+         IF( UPDATE ) THEN
+*
+*           Form  inv(S(i))**H * A * inv(S(i))
+*
+            BII = DBLE( BB( 1, I ) )
+            AB( 1, I ) = ( DBLE( AB( 1, I ) ) / BII ) / BII
+            DO 730 J = I1, I - 1
+               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+  730       CONTINUE
+            DO 740 J = I + 1, MIN( N, I+KA )
+               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+  740       CONTINUE
+            DO 770 K = I + 1, I + KBT
+               DO 750 J = K, I + KBT
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             BB( J-I+1, I )*DCONJG( AB( K-I+1,
+     $                             I ) ) - DCONJG( BB( K-I+1, I ) )*
+     $                             AB( J-I+1, I ) + DBLE( AB( 1, I ) )*
+     $                             BB( J-I+1, I )*DCONJG( BB( K-I+1,
+     $                             I ) )
+  750          CONTINUE
+               DO 760 J = I + KBT + 1, MIN( N, I+KA )
+                  AB( J-K+1, K ) = AB( J-K+1, K ) -
+     $                             DCONJG( BB( K-I+1, I ) )*
+     $                             AB( J-I+1, I )
+  760          CONTINUE
+  770       CONTINUE
+            DO 790 J = I1, I
+               DO 780 K = I + 1, MIN( J+KA, I+KBT )
+                  AB( K-J+1, J ) = AB( K-J+1, J ) -
+     $                             BB( K-I+1, I )*AB( I-J+1, J )
+  780          CONTINUE
+  790       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by inv(S(i))
+*
+               CALL ZDSCAL( NX, ONE / BII, X( 1, I ), 1 )
+               IF( KBT.GT.0 )
+     $            CALL ZGERC( NX, KBT, -CONE, X( 1, I ), 1, BB( 2, I ),
+     $                        1, X( 1, I+1 ), LDX )
+            END IF
+*
+*           store a(i,i1) in RA1 for use in next loop over K
+*
+            RA1 = AB( I-I1+1, I1 )
+         END IF
+*
+*        Generate and apply vectors of rotations to chase all the
+*        existing bulges KA positions up toward the top of the band
+*
+         DO 840 K = 1, KB - 1
+            IF( UPDATE ) THEN
+*
+*              Determine the rotations which would annihilate the bulge
+*              which has in theory just been created
+*
+               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+*                 generate rotation to annihilate a(i,i+k-ka-1)
+*
+                  CALL ZLARTG( AB( KA1-K, I+K-KA ), RA1,
+     $                         RWORK( I+K-KA ), WORK( I+K-KA ), RA )
+*
+*                 create nonzero element a(i+k,i+k-ka-1) outside the
+*                 band and store it in WORK(m-kb+i+k)
+*
+                  T = -BB( K+1, I )*RA1
+                  WORK( M-KB+I+K ) = RWORK( I+K-KA )*T -
+     $                               DCONJG( WORK( I+K-KA ) )*
+     $                               AB( KA1, I+K-KA )
+                  AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
+     $                                RWORK( I+K-KA )*AB( KA1, I+K-KA )
+                  RA1 = RA
+               END IF
+            END IF
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( UPDATE ) THEN
+               J2T = MIN( J2, I-2*KA+K-1 )
+            ELSE
+               J2T = J2
+            END IF
+            NRT = ( J2T+KA-1 ) / KA1
+            DO 800 J = J1, J2T, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(j)
+*
+               WORK( J ) = WORK( J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = RWORK( J )*AB( KA1, J-1 )
+  800       CONTINUE
+*
+*           generate rotations in 1st set to annihilate elements which
+*           have been created outside the band
+*
+            IF( NRT.GT.0 )
+     $         CALL ZLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
+     $                      RWORK( J1 ), KA1 )
+            IF( NR.GT.0 ) THEN
+*
+*              apply rotations in 1st set from the right
+*
+               DO 810 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, RWORK( J1 ), WORK( J1 ), KA1 )
+  810          CONTINUE
+*
+*              apply rotations in 1st set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, RWORK( J1 ),
+     $                      WORK( J1 ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 1st set from the left
+*
+            DO 820 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         RWORK( J1T ), WORK( J1T ), KA1 )
+  820       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 1st set
+*
+               DO 830 J = J1, J2, KA1
+                  CALL ZROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( J ), DCONJG( WORK( J ) ) )
+  830          CONTINUE
+            END IF
+  840    CONTINUE
+*
+         IF( UPDATE ) THEN
+            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+*              create nonzero element a(i+kbt,i+kbt-ka-1) outside the
+*              band and store it in WORK(m-kb+i+kbt)
+*
+               WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
+            END IF
+         END IF
+*
+         DO 880 K = KB, 1, -1
+            IF( UPDATE ) THEN
+               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+            ELSE
+               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            END IF
+*
+*           finish applying rotations in 2nd set from the left
+*
+            DO 850 L = KB - K, 1, -1
+               NRT = ( J2+KA+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
+     $                         AB( KA1-L, J1T+L-1 ), INCA,
+     $                         RWORK( M-KB+J1T+KA ),
+     $                         WORK( M-KB+J1T+KA ), KA1 )
+  850       CONTINUE
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            DO 860 J = J1, J2, KA1
+               WORK( M-KB+J ) = WORK( M-KB+J+KA )
+               RWORK( M-KB+J ) = RWORK( M-KB+J+KA )
+  860       CONTINUE
+            DO 870 J = J1, J2, KA1
+*
+*              create nonzero element a(j+ka,j-1) outside the band
+*              and store it in WORK(m-kb+j)
+*
+               WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
+               AB( KA1, J-1 ) = RWORK( M-KB+J )*AB( KA1, J-1 )
+  870       CONTINUE
+            IF( UPDATE ) THEN
+               IF( I+K.GT.KA1 .AND. K.LE.KBT )
+     $            WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+            END IF
+  880    CONTINUE
+*
+         DO 920 K = KB, 1, -1
+            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+            NR = ( J2+KA-1 ) / KA1
+            J1 = J2 - ( NR-1 )*KA1
+            IF( NR.GT.0 ) THEN
+*
+*              generate rotations in 2nd set to annihilate elements
+*              which have been created outside the band
+*
+               CALL ZLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
+     $                      KA1, RWORK( M-KB+J1 ), KA1 )
+*
+*              apply rotations in 2nd set from the right
+*
+               DO 890 L = 1, KA - 1
+                  CALL ZLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+     $                         INCA, RWORK( M-KB+J1 ), WORK( M-KB+J1 ),
+     $                         KA1 )
+  890          CONTINUE
+*
+*              apply rotations in 2nd set from both sides to diagonal
+*              blocks
+*
+               CALL ZLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+     $                      AB( 2, J1-1 ), INCA, RWORK( M-KB+J1 ),
+     $                      WORK( M-KB+J1 ), KA1 )
+*
+               CALL ZLACGV( NR, WORK( M-KB+J1 ), KA1 )
+            END IF
+*
+*           start applying rotations in 2nd set from the left
+*
+            DO 900 L = KA - 1, KB - K + 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         RWORK( M-KB+J1T ), WORK( M-KB+J1T ),
+     $                         KA1 )
+  900       CONTINUE
+*
+            IF( WANTX ) THEN
+*
+*              post-multiply X by product of rotations in 2nd set
+*
+               DO 910 J = J1, J2, KA1
+                  CALL ZROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+     $                       RWORK( M-KB+J ), DCONJG( WORK( M-KB+J ) ) )
+  910          CONTINUE
+            END IF
+  920    CONTINUE
+*
+         DO 940 K = 1, KB - 1
+            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+*           finish applying rotations in 1st set from the left
+*
+            DO 930 L = KB - K, 1, -1
+               NRT = ( J2+L-1 ) / KA1
+               J1T = J2 - ( NRT-1 )*KA1
+               IF( NRT.GT.0 )
+     $            CALL ZLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+     $                         AB( KA1-L, J1T-KA1+L ), INCA,
+     $                         RWORK( J1T ), WORK( J1T ), KA1 )
+  930       CONTINUE
+  940    CONTINUE
+*
+         IF( KB.GT.1 ) THEN
+            DO 950 J = 2, I2 - KA
+               RWORK( J ) = RWORK( J+KA )
+               WORK( J ) = WORK( J+KA )
+  950       CONTINUE
+         END IF
+*
+      END IF
+*
+      GO TO 490
+*
+*     End of ZHBGST
+*
+      END
diff --git a/SRC/zhbgv.f b/SRC/zhbgv.f
new file mode 100644
index 00000000..534415d0
--- /dev/null
+++ b/SRC/zhbgv.f
@@ -0,0 +1,191 @@
+      SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
+     $                  LDZ, WORK, 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, KA, KB, LDAB, LDBB, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
+*  and banded, and B is also positive definite.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) COMPLEX*16 array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**H*S, as returned by ZPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**H*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 >= N.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  RWORK   (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, and i is:
+*             <= N:  the algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then ZPBSTF
+*                    returned INFO = i: 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          VECT
+      INTEGER            IINFO, INDE, INDWRK
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSTERF, XERBLA, ZHBGST, ZHBTRD, ZPBSTF, ZSTEQR
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL ZPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      CALL ZHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK, RWORK( INDWRK ), IINFO )
+*
+*     Reduce to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL ZHBTRD( VECT, UPLO, N, KA, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call ZSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
+     $                RWORK( INDWRK ), INFO )
+      END IF
+      RETURN
+*
+*     End of ZHBGV
+*
+      END
diff --git a/SRC/zhbgvd.f b/SRC/zhbgvd.f
new file mode 100644
index 00000000..9c2d217d
--- /dev/null
+++ b/SRC/zhbgvd.f
@@ -0,0 +1,297 @@
+      SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
+     $                   Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK,
+     $                   LIWORK, 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, KA, KB, LDAB, LDBB, LDZ, LIWORK, LRWORK,
+     $                   LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
+*  and banded, and B is also positive definite.  If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) COMPLEX*16 array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**H*S, as returned by ZPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**H*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 >= 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.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LRWORK >= N.
+*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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 array IWORK.
+*          If JOBZ = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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, and i is:
+*             <= N:  the algorithm failed to converge:
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero;
+*             > N:   if INFO = N + i, for 1 <= i <= N, then ZPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CONE, CZERO
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          VECT
+      INTEGER            IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLRWK,
+     $                   LLWK2, LRWMIN, LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSTERF, XERBLA, ZGEMM, ZHBGST, ZHBTRD, ZLACPY,
+     $                   ZPBSTF, ZSTEDC
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LWMIN = 1
+         LRWMIN = 1
+         LIWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LWMIN = 2*N**2
+         LRWMIN = 1 + 5*N + 2*N**2
+         LIWMIN = 3 + 5*N
+      ELSE
+         LWMIN = N
+         LRWMIN = N
+         LIWMIN = 1
+      END IF
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -7
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -14
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -16
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL ZPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      INDE = 1
+      INDWRK = INDE + N
+      INDWK2 = 1 + N*N
+      LLWK2 = LWORK - INDWK2 + 2
+      LLRWK = LRWORK - INDWRK + 2
+      CALL ZHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+     $             WORK, RWORK( INDWRK ), IINFO )
+*
+*     Reduce Hermitian band matrix to tridiagonal form.
+*
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL ZHBTRD( VECT, UPLO, N, KA, AB, LDAB, W, RWORK( INDE ), Z,
+     $             LDZ, WORK, IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, call ZSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK, N, WORK( INDWK2 ),
+     $                LLWK2, RWORK( INDWRK ), LLRWK, IWORK, LIWORK,
+     $                INFO )
+         CALL ZGEMM( 'N', 'N', N, N, N, CONE, Z, LDZ, WORK, N, CZERO,
+     $               WORK( INDWK2 ), N )
+         CALL ZLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of ZHBGVD
+*
+      END
diff --git a/SRC/zhbgvx.f b/SRC/zhbgvx.f
new file mode 100644
index 00000000..28258d90
--- /dev/null
+++ b/SRC/zhbgvx.f
@@ -0,0 +1,390 @@
+      SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB,
+     $                   LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z,
+     $                   LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
+     $                   N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-definite banded eigenproblem, of
+*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
+*  and banded, and B is also positive definite.  Eigenvalues and
+*  eigenvectors can be selected by specifying either all eigenvalues,
+*  a range of values or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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.
+*
+*  KA      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+*  KB      (input) INTEGER
+*          The number of superdiagonals of the matrix B if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first ka+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
+*
+*          On exit, the contents of AB are destroyed.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KA+1.
+*
+*  BB      (input/output) COMPLEX*16 array, dimension (LDBB, N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix B, stored in the first kb+1 rows of the array.  The
+*          j-th column of B is stored in the j-th column of the array BB
+*          as follows:
+*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
+*
+*          On exit, the factor S from the split Cholesky factorization
+*          B = S**H*S, as returned by ZPBSTF.
+*
+*  LDBB    (input) INTEGER
+*          The leading dimension of the array BB.  LDBB >= KB+1.
+*
+*  Q       (output) COMPLEX*16 array, dimension (LDQ, N)
+*          If JOBZ = 'V', the n-by-n matrix used in the reduction of
+*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
+*          and consequently C to tridiagonal form.
+*          If JOBZ = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  If JOBZ = 'N',
+*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors, with the i-th column of Z holding the
+*          eigenvector associated with W(i). The eigenvectors are
+*          normalized so that Z**H*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 >= N.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  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:  then i eigenvectors failed to converge.  Their
+*                    indices are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then ZPBSTF
+*                    returned INFO = i: B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
+      CHARACTER          ORDER, VECT
+      INTEGER            I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
+     $                   INDIWK, INDRWK, INDWRK, ITMP1, J, JJ, NSPLIT
+      DOUBLE PRECISION   TMP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSTEBZ, DSTERF, XERBLA, ZCOPY, ZGEMV,
+     $                   ZHBGST, ZHBTRD, ZLACPY, ZPBSTF, ZSTEIN, ZSTEQR,
+     $                   ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KA.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KA+1 ) THEN
+         INFO = -8
+      ELSE IF( LDBB.LT.KB+1 ) THEN
+         INFO = -10
+      ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
+         INFO = -12
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -14
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -15
+            ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -16
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -21
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a split Cholesky factorization of B.
+*
+      CALL ZPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem.
+*
+      CALL ZHBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
+     $             WORK, RWORK, IINFO )
+*
+*     Solve the standard eigenvalue problem.
+*     Reduce Hermitian band matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDWRK = 1
+      IF( WANTZ ) THEN
+         VECT = 'U'
+      ELSE
+         VECT = 'N'
+      END IF
+      CALL ZHBTRD( VECT, UPLO, N, KA, AB, LDAB, RWORK( INDD ),
+     $             RWORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call DSTERF or ZSTEQR.  If this fails for some
+*     eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+         IF( .NOT.WANTZ ) THEN
+            CALL DSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL ZLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+            CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired,
+*     call ZSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by ZSTEIN.
+*
+         DO 20 J = 1, M
+            CALL ZCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+            CALL ZGEMV( 'N', N, N, CONE, Q, LDQ, WORK, 1, CZERO,
+     $                  Z( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+   30 CONTINUE
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHBGVX
+*
+      END
diff --git a/SRC/zhbtrd.f b/SRC/zhbtrd.f
new file mode 100644
index 00000000..40b643cb
--- /dev/null
+++ b/SRC/zhbtrd.f
@@ -0,0 +1,588 @@
+      SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, 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, VECT
+      INTEGER            INFO, KD, LDAB, LDQ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         AB( LDAB, * ), Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHBTRD reduces a complex Hermitian band matrix A to real symmetric
+*  tridiagonal form T by a unitary similarity transformation:
+*  Q**H * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'N':  do not form Q;
+*          = 'V':  form Q;
+*          = 'U':  update a matrix X, by forming X*Q.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          On exit, the diagonal elements of AB are overwritten by the
+*          diagonal elements of the tridiagonal matrix T; if KD > 0, the
+*          elements on the first superdiagonal (if UPLO = 'U') or the
+*          first subdiagonal (if UPLO = 'L') are overwritten by the
+*          off-diagonal elements of T; the rest of AB is overwritten by
+*          values generated during the reduction.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T.
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*          On entry, if VECT = 'U', then Q must contain an N-by-N
+*          matrix X; if VECT = 'N' or 'V', then Q need not be set.
+*
+*          On exit:
+*          if VECT = 'V', Q contains the N-by-N unitary matrix Q;
+*          if VECT = 'U', Q contains the product X*Q;
+*          if VECT = 'N', the array Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
+*
+*  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
+*  ===============
+*
+*  Modified by Linda Kaufman, Bell Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            INITQ, UPPER, WANTQ
+      INTEGER            I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
+     $                   J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
+     $                   KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
+      DOUBLE PRECISION   ABST
+      COMPLEX*16         T, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACGV, ZLAR2V, ZLARGV, ZLARTG, ZLARTV,
+     $                   ZLASET, ZROT, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INITQ = LSAME( VECT, 'V' )
+      WANTQ = INITQ .OR. LSAME( VECT, 'U' )
+      UPPER = LSAME( UPLO, 'U' )
+      KD1 = KD + 1
+      KDM1 = KD - 1
+      INCX = LDAB - 1
+      IQEND = 1
+*
+      INFO = 0
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD1 ) THEN
+         INFO = -6
+      ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHBTRD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Initialize Q to the unit matrix, if needed
+*
+      IF( INITQ )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+*
+*     Wherever possible, plane rotations are generated and applied in
+*     vector operations of length NR over the index set J1:J2:KD1.
+*
+*     The real cosines and complex sines of the plane rotations are
+*     stored in the arrays D and WORK.
+*
+      INCA = KD1*LDAB
+      KDN = MIN( N-1, KD )
+      IF( UPPER ) THEN
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to complex Hermitian tridiagonal form, working with
+*           the upper triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            AB( KD1, 1 ) = DBLE( AB( KD1, 1 ) )
+            DO 90 I = 1, N - 2
+*
+*              Reduce i-th row of matrix to tridiagonal form
+*
+               DO 80 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL ZLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
+     $                            KD1, D( J1 ), KD1 )
+*
+*                    apply rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    ZLARTV or ZROT is used
+*
+                     IF( NR.GE.2*KD-1 ) THEN
+                        DO 10 L = 1, KD - 1
+                           CALL ZLARTV( NR, AB( L+1, J1-1 ), INCA,
+     $                                  AB( L, J1 ), INCA, D( J1 ),
+     $                                  WORK( J1 ), KD1 )
+   10                   CONTINUE
+*
+                     ELSE
+                        JEND = J1 + ( NR-1 )*KD1
+                        DO 20 JINC = J1, JEND, KD1
+                           CALL ZROT( KDM1, AB( 2, JINC-1 ), 1,
+     $                                AB( 1, JINC ), 1, D( JINC ),
+     $                                WORK( JINC ) )
+   20                   CONTINUE
+                     END IF
+                  END IF
+*
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i,i+k-1)
+*                       within the band
+*
+                        CALL ZLARTG( AB( KD-K+3, I+K-2 ),
+     $                               AB( KD-K+2, I+K-1 ), D( I+K-1 ),
+     $                               WORK( I+K-1 ), TEMP )
+                        AB( KD-K+3, I+K-2 ) = TEMP
+*
+*                       apply rotation from the right
+*
+                        CALL ZROT( K-3, AB( KD-K+4, I+K-2 ), 1,
+     $                             AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL ZLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
+     $                            AB( KD, J1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the left
+*
+                  IF( NR.GT.0 ) THEN
+                     CALL ZLACGV( NR, WORK( J1 ), KD1 )
+                     IF( 2*KD-1.LT.NR ) THEN
+*
+*                    Dependent on the the number of diagonals either
+*                    ZLARTV or ZROT is used
+*
+                        DO 30 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL ZLARTV( NRT, AB( KD-L, J1+L ), INCA,
+     $                                     AB( KD-L+1, J1+L ), INCA,
+     $                                     D( J1 ), WORK( J1 ), KD1 )
+   30                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 40 JIN = J1, J1END, KD1
+                              CALL ZROT( KD-1, AB( KD-1, JIN+1 ), INCX,
+     $                                   AB( KD, JIN+1 ), INCX,
+     $                                   D( JIN ), WORK( JIN ) )
+   40                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL ZROT( LEND, AB( KD-1, LAST+1 ), INCX,
+     $                                AB( KD, LAST+1 ), INCX, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 50 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL ZROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), DCONJG( WORK( J ) ) )
+   50                   CONTINUE
+                     ELSE
+*
+                        DO 60 J = J1, J2, KD1
+                           CALL ZROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), DCONJG( WORK( J ) ) )
+   60                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 70 J = J1, J2, KD1
+*
+*                    create nonzero element a(j-1,j+kd) outside the band
+*                    and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
+                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
+   70             CONTINUE
+   80          CONTINUE
+   90       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           make off-diagonal elements real and copy them to E
+*
+            DO 100 I = 1, N - 1
+               T = AB( KD, I+1 )
+               ABST = ABS( T )
+               AB( KD, I+1 ) = ABST
+               E( I ) = ABST
+               IF( ABST.NE.ZERO ) THEN
+                  T = T / ABST
+               ELSE
+                  T = CONE
+               END IF
+               IF( I.LT.N-1 )
+     $            AB( KD, I+2 ) = AB( KD, I+2 )*T
+               IF( WANTQ ) THEN
+                  CALL ZSCAL( N, DCONJG( T ), Q( 1, I+1 ), 1 )
+               END IF
+  100       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 110 I = 1, N - 1
+               E( I ) = ZERO
+  110       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 120 I = 1, N
+            D( I ) = AB( KD1, I )
+  120    CONTINUE
+*
+      ELSE
+*
+         IF( KD.GT.1 ) THEN
+*
+*           Reduce to complex Hermitian tridiagonal form, working with
+*           the lower triangle
+*
+            NR = 0
+            J1 = KDN + 2
+            J2 = 1
+*
+            AB( 1, 1 ) = DBLE( AB( 1, 1 ) )
+            DO 210 I = 1, N - 2
+*
+*              Reduce i-th column of matrix to tridiagonal form
+*
+               DO 200 K = KDN + 1, 2, -1
+                  J1 = J1 + KDN
+                  J2 = J2 + KDN
+*
+                  IF( NR.GT.0 ) THEN
+*
+*                    generate plane rotations to annihilate nonzero
+*                    elements which have been created outside the band
+*
+                     CALL ZLARGV( NR, AB( KD1, J1-KD1 ), INCA,
+     $                            WORK( J1 ), KD1, D( J1 ), KD1 )
+*
+*                    apply plane rotations from one side
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    ZLARTV or ZROT is used
+*
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 130 L = 1, KD - 1
+                           CALL ZLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
+     $                                  AB( KD1-L+1, J1-KD1+L ), INCA,
+     $                                  D( J1 ), WORK( J1 ), KD1 )
+  130                   CONTINUE
+                     ELSE
+                        JEND = J1 + KD1*( NR-1 )
+                        DO 140 JINC = J1, JEND, KD1
+                           CALL ZROT( KDM1, AB( KD, JINC-KD ), INCX,
+     $                                AB( KD1, JINC-KD ), INCX,
+     $                                D( JINC ), WORK( JINC ) )
+  140                   CONTINUE
+                     END IF
+*
+                  END IF
+*
+                  IF( K.GT.2 ) THEN
+                     IF( K.LE.N-I+1 ) THEN
+*
+*                       generate plane rotation to annihilate a(i+k-1,i)
+*                       within the band
+*
+                        CALL ZLARTG( AB( K-1, I ), AB( K, I ),
+     $                               D( I+K-1 ), WORK( I+K-1 ), TEMP )
+                        AB( K-1, I ) = TEMP
+*
+*                       apply rotation from the left
+*
+                        CALL ZROT( K-3, AB( K-2, I+1 ), LDAB-1,
+     $                             AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
+     $                             WORK( I+K-1 ) )
+                     END IF
+                     NR = NR + 1
+                     J1 = J1 - KDN - 1
+                  END IF
+*
+*                 apply plane rotations from both sides to diagonal
+*                 blocks
+*
+                  IF( NR.GT.0 )
+     $               CALL ZLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
+     $                            AB( 2, J1-1 ), INCA, D( J1 ),
+     $                            WORK( J1 ), KD1 )
+*
+*                 apply plane rotations from the right
+*
+*
+*                    Dependent on the the number of diagonals either
+*                    ZLARTV or ZROT is used
+*
+                  IF( NR.GT.0 ) THEN
+                     CALL ZLACGV( NR, WORK( J1 ), KD1 )
+                     IF( NR.GT.2*KD-1 ) THEN
+                        DO 150 L = 1, KD - 1
+                           IF( J2+L.GT.N ) THEN
+                              NRT = NR - 1
+                           ELSE
+                              NRT = NR
+                           END IF
+                           IF( NRT.GT.0 )
+     $                        CALL ZLARTV( NRT, AB( L+2, J1-1 ), INCA,
+     $                                     AB( L+1, J1 ), INCA, D( J1 ),
+     $                                     WORK( J1 ), KD1 )
+  150                   CONTINUE
+                     ELSE
+                        J1END = J1 + KD1*( NR-2 )
+                        IF( J1END.GE.J1 ) THEN
+                           DO 160 J1INC = J1, J1END, KD1
+                              CALL ZROT( KDM1, AB( 3, J1INC-1 ), 1,
+     $                                   AB( 2, J1INC ), 1, D( J1INC ),
+     $                                   WORK( J1INC ) )
+  160                      CONTINUE
+                        END IF
+                        LEND = MIN( KDM1, N-J2 )
+                        LAST = J1END + KD1
+                        IF( LEND.GT.0 )
+     $                     CALL ZROT( LEND, AB( 3, LAST-1 ), 1,
+     $                                AB( 2, LAST ), 1, D( LAST ),
+     $                                WORK( LAST ) )
+                     END IF
+                  END IF
+*
+*
+*
+                  IF( WANTQ ) THEN
+*
+*                    accumulate product of plane rotations in Q
+*
+                     IF( INITQ ) THEN
+*
+*                 take advantage of the fact that Q was
+*                 initially the Identity matrix
+*
+                        IQEND = MAX( IQEND, J2 )
+                        I2 = MAX( 0, K-3 )
+                        IQAEND = 1 + I*KD
+                        IF( K.EQ.2 )
+     $                     IQAEND = IQAEND + KD
+                        IQAEND = MIN( IQAEND, IQEND )
+                        DO 170 J = J1, J2, KD1
+                           IBL = I - I2 / KDM1
+                           I2 = I2 + 1
+                           IQB = MAX( 1, J-IBL )
+                           NQ = 1 + IQAEND - IQB
+                           IQAEND = MIN( IQAEND+KD, IQEND )
+                           CALL ZROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+     $                                1, D( J ), WORK( J ) )
+  170                   CONTINUE
+                     ELSE
+*
+                        DO 180 J = J1, J2, KD1
+                           CALL ZROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+     $                                D( J ), WORK( J ) )
+  180                   CONTINUE
+                     END IF
+                  END IF
+*
+                  IF( J2+KDN.GT.N ) THEN
+*
+*                    adjust J2 to keep within the bounds of the matrix
+*
+                     NR = NR - 1
+                     J2 = J2 - KDN - 1
+                  END IF
+*
+                  DO 190 J = J1, J2, KD1
+*
+*                    create nonzero element a(j+kd,j-1) outside the
+*                    band and store it in WORK
+*
+                     WORK( J+KD ) = WORK( J )*AB( KD1, J )
+                     AB( KD1, J ) = D( J )*AB( KD1, J )
+  190             CONTINUE
+  200          CONTINUE
+  210       CONTINUE
+         END IF
+*
+         IF( KD.GT.0 ) THEN
+*
+*           make off-diagonal elements real and copy them to E
+*
+            DO 220 I = 1, N - 1
+               T = AB( 2, I )
+               ABST = ABS( T )
+               AB( 2, I ) = ABST
+               E( I ) = ABST
+               IF( ABST.NE.ZERO ) THEN
+                  T = T / ABST
+               ELSE
+                  T = CONE
+               END IF
+               IF( I.LT.N-1 )
+     $            AB( 2, I+1 ) = AB( 2, I+1 )*T
+               IF( WANTQ ) THEN
+                  CALL ZSCAL( N, T, Q( 1, I+1 ), 1 )
+               END IF
+  220       CONTINUE
+         ELSE
+*
+*           set E to zero if original matrix was diagonal
+*
+            DO 230 I = 1, N - 1
+               E( I ) = ZERO
+  230       CONTINUE
+         END IF
+*
+*        copy diagonal elements to D
+*
+         DO 240 I = 1, N
+            D( I ) = AB( 1, I )
+  240    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHBTRD
+*
+      END
diff --git a/SRC/zhecon.f b/SRC/zhecon.f
new file mode 100644
index 00000000..d5f72e89
--- /dev/null
+++ b/SRC/zhecon.f
@@ -0,0 +1,163 @@
+      SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+     $                   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          UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHECON estimates the reciprocal of the condition number of a complex
+*  Hermitian matrix A using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by ZHETRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZHETRF.
+*
+*  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 ZHETRF.
+*
+*  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) COMPLEX*16 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            UPPER
+      INTEGER            I, KASE
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHETRS, ZLACN2
+*     ..
+*     .. 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( 'ZHECON', -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 ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL ZHETRS( 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 ZHECON
+*
+      END
diff --git a/SRC/zheev.f b/SRC/zheev.f
new file mode 100644
index 00000000..324d1612
--- /dev/null
+++ b/SRC/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/zheevd.f b/SRC/zheevd.f
new file mode 100644
index 00000000..d8258374
--- /dev/null
+++ b/SRC/zheevd.f
@@ -0,0 +1,305 @@
+      SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
+     $                   LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
+*  complex Hermitian matrix A.  If eigenvectors are desired, it uses a
+*  divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*          If N <= 1,                LWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LWORK must be at least N + 1.
+*          If JOBZ  = 'V' and N > 1, LWORK must be at least 2*N + N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array,
+*                                         dimension (LRWORK)
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of the array RWORK.
+*          If N <= 1,                LRWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LRWORK must be at least N.
+*          If JOBZ  = 'V' and N > 1, LRWORK must be at least
+*                         1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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.
+*          If N <= 1,                LIWORK must be at least 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed
+*                to converge; i off-diagonal elements of an intermediate
+*                tridiagonal form did not converge to zero;
+*                if INFO = i and JOBZ = 'V', then the algorithm failed
+*                to compute an eigenvalue while working on the submatrix
+*                lying in rows and columns INFO/(N+1) through
+*                mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  Modified description of INFO. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. 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, INDRWK, INDTAU, INDWK2,
+     $                   INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK,
+     $                   LLWRK2, LOPT, LROPT, LRWMIN, LWMIN
+      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, ZLACPY, ZLASCL,
+     $                   ZSTEDC, ZUNMTR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+            LRWMIN = 1
+            LIWMIN = 1
+            LOPT = LWMIN
+            LROPT = LRWMIN
+            LIOPT = LIWMIN
+         ELSE
+            IF( WANTZ ) THEN
+               LWMIN = 2*N + N*N
+               LRWMIN = 1 + 5*N + 2*N**2
+               LIWMIN = 3 + 5*N
+            ELSE
+               LWMIN = N + 1
+               LRWMIN = N
+               LIWMIN = 1
+            END IF
+            LOPT = MAX( LWMIN, N +
+     $                  ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
+            LROPT = LRWMIN
+            LIOPT = LIWMIN
+         END IF
+         WORK( 1 ) = LOPT
+         RWORK( 1 ) = LROPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = A( 1, 1 )
+         IF( WANTZ )
+     $      A( 1, 1 ) = 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
+      INDRWK = INDE + N
+      INDWK2 = INDWRK + N*N
+      LLWORK = LWORK - INDWRK + 1
+      LLWRK2 = LWORK - INDWK2 + 1
+      LLRWK = LRWORK - INDRWK + 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
+*     ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+*     tridiagonal matrix, then call ZUNMTR to multiply it to the
+*     Householder transformations represented as Householder vectors in
+*     A.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N,
+     $                WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK,
+     $                IWORK, LIWORK, INFO )
+         CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
+     $                WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
+         CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
+      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
+*
+      WORK( 1 ) = LOPT
+      RWORK( 1 ) = LROPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of ZHEEVD
+*
+      END
diff --git a/SRC/zheevr.f b/SRC/zheevr.f
new file mode 100644
index 00000000..af8c9fcb
--- /dev/null
+++ b/SRC/zheevr.f
@@ -0,0 +1,588 @@
+      SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
+     $                   RWORK, LRWORK, IWORK, LIWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK,
+     $                   M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEEVR computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can
+*  be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  ZHEEVR first reduces the matrix A to tridiagonal form T with a call
+*  to ZHETRD.  Then, whenever possible, ZHEEVR calls ZSTEMR to compute
+*  eigenspectrum using Relatively Robust Representations.  ZSTEMR
+*  computes eigenvalues by the dqds algorithm, while orthogonal
+*  eigenvectors are computed from various "good" L D L^T representations
+*  (also known as Relatively Robust Representations). Gram-Schmidt
+*  orthogonalization is avoided as far as possible. More specifically,
+*  the various steps of the algorithm are as follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  The desired accuracy of the output can be specified by the input
+*  parameter ABSTOL.
+*
+*  For more details, see DSTEMR's documentation and:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*
+*  Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested
+*  on machines which conform to the ieee-754 floating point standard.
+*  ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and
+*  when partial spectrum requests are made.
+*
+*  Normal execution of ZSTEMR may create NaNs and infinities and
+*  hence may abort due to a floating point exception in environments
+*  which do not handle NaNs and infinities in the ieee standard default
+*  manner.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
+********** ZSTEIN are called
+*
+*  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, 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).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*          If high relative accuracy is important, set ABSTOL to
+*          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that
+*          eigenvalues are computed to high relative accuracy when
+*          possible in future releases.  The current code does not
+*          make any guarantees about high relative accuracy, but
+*          furutre releases will. See J. Barlow and J. Demmel,
+*          "Computing Accurate Eigensystems of Scaled Diagonally
+*          Dominant Matrices", LAPACK Working Note #7, for a discussion
+*          of which matrices define their eigenvalues to high relative
+*          accuracy.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+*  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).
+*          For optimal efficiency, LWORK >= (NB+1)*N,
+*          where NB is the max of the blocksize for ZHETRD and for
+*          ZUNMTR as returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the optimal
+*          (and minimal) LRWORK.
+*
+* LRWORK   (input) INTEGER
+*          The length of the array RWORK.  LRWORK >= max(1,24*N).
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal
+*          (and minimal) LIWORK.
+*
+* LIWORK   (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  Internal error
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Ken Stanley, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Jason Riedy, Computer Science Division, University of
+*       California at Berkeley, USA
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ, TRYRAC
+      CHARACTER          ORDER
+      INTEGER            I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP,
+     $                   INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK,
+     $                   INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ,
+     $                   LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN,
+     $                   LWKOPT, LWMIN, NB, NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANSY
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
+     $                   ZHETRD, ZSTEMR, ZSTEIN, ZSWAP, ZUNMTR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      IEEEOK = ILAENV( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 )
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR.
+     $         ( LIWORK.EQ.-1 ) )
+*
+      LRWMIN = MAX( 1, 24*N )
+      LIWMIN = MAX( 1, 10*N )
+      LWMIN = MAX( 1, 2*N )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
+         NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) )
+         LWKOPT = MAX( ( NB+1 )*N, LWMIN )
+         WORK( 1 ) = LWKOPT
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -22
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEEVR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         WORK( 1 ) = 2
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = DBLE( A( 1, 1 ) )
+         ELSE
+            IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) )
+     $           THEN
+               M = 1
+               W( 1 ) = DBLE( A( 1, 1 ) )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF (VALEIG) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = ZLANSY( 'M', UPLO, N, A, LDA, RWORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+
+*     Initialize indices into workspaces.  Note: The IWORK indices are
+*     used only if DSTERF or ZSTEMR fail.
+
+*     WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the
+*     elementary reflectors used in ZHETRD.
+      INDTAU = 1
+*     INDWK is the starting offset of the remaining complex workspace,
+*     and LLWORK is the remaining complex workspace size.
+      INDWK = INDTAU + N
+      LLWORK = LWORK - INDWK + 1
+
+*     RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal
+*     entries.
+      INDRD = 1
+*     RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the
+*     tridiagonal matrix from ZHETRD.
+      INDRE = INDRD + N
+*     RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over
+*     -written by ZSTEMR (the DSTERF path copies the diagonal to W).
+      INDRDD = INDRE + N
+*     RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over
+*     -written while computing the eigenvalues in DSTERF and ZSTEMR.
+      INDREE = INDRDD + N
+*     INDRWK is the starting offset of the left-over real workspace, and
+*     LLRWORK is the remaining workspace size.
+      INDRWK = INDREE + N
+      LLRWORK = LRWORK - INDRWK + 1
+
+*     IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
+*     stores the block indices of each of the M<=N eigenvalues.
+      INDIBL = 1
+*     IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
+*     stores the starting and finishing indices of each block.
+      INDISP = INDIBL + N
+*     IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+*     that corresponding to eigenvectors that fail to converge in
+*     DSTEIN.  This information is discarded; if any fail, the driver
+*     returns INFO > 0.
+      INDIFL = INDISP + N
+*     INDIWO is the offset of the remaining integer workspace.
+      INDIWO = INDISP + N
+
+*
+*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDRD ), RWORK( INDRE ),
+     $             WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired
+*     then call DSTERF or ZSTEMR and ZUNMTR.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 )
+            CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 )
+            CALL DSTERF( N, W, RWORK( INDREE ), INFO )
+         ELSE
+            CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 )
+            CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 )
+*
+            IF (ABSTOL .LE. TWO*N*EPS) THEN
+               TRYRAC = .TRUE.
+            ELSE
+               TRYRAC = .FALSE.
+            END IF
+            CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ),
+     $                   RWORK( INDREE ), VL, VU, IL, IU, M, W,
+     $                   Z, LDZ, N, ISUPPZ, TRYRAC,
+     $                   RWORK( INDRWK ), LLRWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*           Apply unitary matrix used in reduction to tridiagonal
+*           form to eigenvectors returned by ZSTEIN.
+*
+            IF( WANTZ .AND. INFO.EQ.0 ) THEN
+               INDWKN = INDWK
+               LLWRKN = LWORK - INDWKN + 1
+               CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA,
+     $                      WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
+     $                      LLWRKN, IINFO )
+            END IF
+         END IF
+*
+*
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 30
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
+*     Also call DSTEBZ and ZSTEIN if ZSTEMR fails.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWO ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL ZSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ),
+     $                INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by ZSTEIN.
+*
+         INDWKN = INDWK
+         LLWRKN = LWORK - INDWKN + 1
+         CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   30 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 50 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 40 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   40       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+            END IF
+   50    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of ZHEEVR
+*
+      END
diff --git a/SRC/zheevx.f b/SRC/zheevx.f
new file mode 100644
index 00000000..4c378ce2
--- /dev/null
+++ b/SRC/zheevx.f
@@ -0,0 +1,439 @@
+      SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDA, LDZ, LWORK, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can
+*  be selected by specifying either a range of values or a range of
+*  indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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, 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).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,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 length of the array WORK.  LWORK >= 1, when N <= 1;
+*          otherwise 2*N.
+*          For optimal efficiency, LWORK >= (NB+1)*N,
+*          where NB is the max of the blocksize for ZHETRD and for
+*          ZUNMTR as 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 (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      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 ..
+      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+     $                   WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
+     $                   ITMP1, J, JJ, LLWORK, LWKMIN, LWKOPT, NB,
+     $                   NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANHE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANHE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
+     $                   ZHETRD, ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR,
+     $                   ZUNMTR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LOWER = LSAME( UPLO, 'L' )
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -8
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -9
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -10
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWKMIN = 1
+            WORK( 1 ) = LWKMIN
+         ELSE
+            LWKMIN = 2*N
+            NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
+            NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) )
+            LWKOPT = MAX( 1, ( NB + 1 )*N )
+            WORK( 1 ) = LWKOPT
+         END IF
+*
+         IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY )
+     $      INFO = -17
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEEVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = A( 1, 1 )
+         ELSE IF( VALEIG ) THEN
+            IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) )
+     $           THEN
+               M = 1
+               W( 1 ) = A( 1, 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      END IF
+      ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         IF( LOWER ) THEN
+            DO 10 J = 1, N
+               CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+   10       CONTINUE
+         ELSE
+            DO 20 J = 1, N
+               CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 )
+   20       CONTINUE
+         END IF
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDD ), RWORK( INDE ),
+     $             WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal to
+*     zero, then call DSTERF or ZUNGTR and ZSTEQR.  If this fails for
+*     some eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF( INDEIG ) THEN
+         IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+         CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL DSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ )
+            CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
+     $                   WORK( INDWRK ), LLWORK, IINFO )
+            CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 30 I = 1, N
+                  IFAIL( I ) = 0
+   30          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 40
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by ZSTEIN.
+*
+         CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+     $                LDZ, WORK( INDWRK ), LLWORK, IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   40 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 60 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 50 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   50       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   60    CONTINUE
+      END IF
+*
+*     Set WORK(1) to optimal complex workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZHEEVX
+*
+      END
diff --git a/SRC/zhegs2.f b/SRC/zhegs2.f
new file mode 100644
index 00000000..3b2141d5
--- /dev/null
+++ b/SRC/zhegs2.f
@@ -0,0 +1,224 @@
+      SUBROUTINE ZHEGS2( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEGS2 reduces a complex Hermitian-definite generalized
+*  eigenproblem to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
+*
+*  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` or L'*A*L.
+*
+*  B must have been previously factorized as U'*U or L*L' by ZPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
+*          = 2 or 3: compute U*A*U' or L'*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          Hermitian matrix A is stored, and how B has been factorized.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  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 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 transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by ZPOTRF.
+*
+*  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, HALF
+      PARAMETER          ( ONE = 1.0D+0, HALF = 0.5D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K
+      DOUBLE PRECISION   AKK, BKK
+      COMPLEX*16         CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV,
+     $                   ZTRSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEGS2', -INFO )
+         RETURN
+      END IF
+*
+      IF( ITYPE.EQ.1 ) THEN
+         IF( UPPER ) THEN
+*
+*           Compute inv(U')*A*inv(U)
+*
+            DO 10 K = 1, N
+*
+*              Update the upper triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
+                  CT = -HALF*AKK
+                  CALL ZLACGV( N-K, A( K, K+1 ), LDA )
+                  CALL ZLACGV( N-K, B( K, K+1 ), LDB )
+                  CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA,
+     $                        B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
+                  CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL ZLACGV( N-K, B( K, K+1 ), LDB )
+                  CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit',
+     $                        N-K, B( K+1, K+1 ), LDB, A( K, K+1 ),
+     $                        LDA )
+                  CALL ZLACGV( N-K, A( K, K+1 ), LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute inv(L)*A*inv(L')
+*
+            DO 20 K = 1, N
+*
+*              Update the lower triangle of A(k:n,k:n)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               AKK = AKK / BKK**2
+               A( K, K ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
+                  CT = -HALF*AKK
+                  CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1,
+     $                        B( K+1, K ), 1, A( K+1, K+1 ), LDA )
+                  CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+                  CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
+     $                        B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
+               END IF
+   20       CONTINUE
+         END IF
+      ELSE
+         IF( UPPER ) THEN
+*
+*           Compute U*A*U'
+*
+            DO 30 K = 1, N
+*
+*              Update the upper triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
+     $                     LDB, A( 1, K ), 1 )
+               CT = HALF*AKK
+               CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1,
+     $                     A, LDA )
+               CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+               CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 )
+               A( K, K ) = AKK*BKK**2
+   30       CONTINUE
+         ELSE
+*
+*           Compute L'*A*L
+*
+            DO 40 K = 1, N
+*
+*              Update the lower triangle of A(1:k,1:k)
+*
+               AKK = A( K, K )
+               BKK = B( K, K )
+               CALL ZLACGV( K-1, A( K, 1 ), LDA )
+               CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1,
+     $                     B, LDB, A( K, 1 ), LDA )
+               CT = HALF*AKK
+               CALL ZLACGV( K-1, B( K, 1 ), LDB )
+               CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ),
+     $                     LDB, A, LDA )
+               CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+               CALL ZLACGV( K-1, B( K, 1 ), LDB )
+               CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA )
+               CALL ZLACGV( K-1, A( K, 1 ), LDA )
+               A( K, K ) = AKK*BKK**2
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZHEGS2
+*
+      END
diff --git a/SRC/zhegst.f b/SRC/zhegst.f
new file mode 100644
index 00000000..0d50d367
--- /dev/null
+++ b/SRC/zhegst.f
@@ -0,0 +1,259 @@
+      SUBROUTINE ZHEGST( ITYPE, UPLO, N, 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, ITYPE, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEGST reduces a complex Hermitian-definite generalized
+*  eigenproblem to standard form.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
+*
+*  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**H or L**H*A*L.
+*
+*  B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
+*          = 2 or 3: compute U*A*U**H or L**H*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored and B is factored as
+*                  U**H*U;
+*          = 'L':  Lower triangle of A is stored and B is factored as
+*                  L*L**H.
+*
+*  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 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 transformed matrix, stored in the
+*          same format as A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,N)
+*          The triangular factor from the Cholesky factorization of B,
+*          as returned by ZPOTRF.
+*
+*  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 )
+      COMPLEX*16         CONE, HALF
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHEGS2, ZHEMM, ZHER2K, ZTRMM, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEGST', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'ZHEGST', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ITYPE.EQ.1 ) THEN
+            IF( UPPER ) THEN
+*
+*              Compute inv(U')*A*inv(U)
+*
+               DO 10 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(k:n,k:n)
+*
+                  CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL ZTRSM( 'Left', UPLO, 'Conjugate transpose',
+     $                           'Non-unit', KB, N-K-KB+1, CONE,
+     $                           B( K, K ), LDB, A( K, K+KB ), LDA )
+                     CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB,
+     $                           CONE, A( K, K+KB ), LDA )
+                     CALL ZHER2K( UPLO, 'Conjugate transpose', N-K-KB+1,
+     $                            KB, -CONE, A( K, K+KB ), LDA,
+     $                            B( K, K+KB ), LDB, ONE,
+     $                            A( K+KB, K+KB ), LDA )
+                     CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+     $                           A( K, K ), LDA, B( K, K+KB ), LDB,
+     $                           CONE, A( K, K+KB ), LDA )
+                     CALL ZTRSM( 'Right', UPLO, 'No transpose',
+     $                           'Non-unit', KB, N-K-KB+1, CONE,
+     $                           B( K+KB, K+KB ), LDB, A( K, K+KB ),
+     $                           LDA )
+                  END IF
+   10          CONTINUE
+            ELSE
+*
+*              Compute inv(L)*A*inv(L')
+*
+               DO 20 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(k:n,k:n)
+*
+                  CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+                  IF( K+KB.LE.N ) THEN
+                     CALL ZTRSM( 'Right', UPLO, 'Conjugate transpose',
+     $                           'Non-unit', N-K-KB+1, KB, CONE,
+     $                           B( K, K ), LDB, A( K+KB, K ), LDA )
+                     CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB,
+     $                           CONE, A( K+KB, K ), LDA )
+                     CALL ZHER2K( UPLO, 'No transpose', N-K-KB+1, KB,
+     $                            -CONE, A( K+KB, K ), LDA,
+     $                            B( K+KB, K ), LDB, ONE,
+     $                            A( K+KB, K+KB ), LDA )
+                     CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+     $                           A( K, K ), LDA, B( K+KB, K ), LDB,
+     $                           CONE, A( K+KB, K ), LDA )
+                     CALL ZTRSM( 'Left', UPLO, 'No transpose',
+     $                           'Non-unit', N-K-KB+1, KB, CONE,
+     $                           B( K+KB, K+KB ), LDB, A( K+KB, K ),
+     $                           LDA )
+                  END IF
+   20          CONTINUE
+            END IF
+         ELSE
+            IF( UPPER ) THEN
+*
+*              Compute U*A*U'
+*
+               DO 30 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
+     $                        K-1, KB, CONE, B, LDB, A( 1, K ), LDA )
+                  CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, CONE, A( 1, K ),
+     $                        LDA )
+                  CALL ZHER2K( UPLO, 'No transpose', K-1, KB, CONE,
+     $                         A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
+     $                         LDA )
+                  CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+     $                        LDA, B( 1, K ), LDB, CONE, A( 1, K ),
+     $                        LDA )
+                  CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose',
+     $                        'Non-unit', K-1, KB, CONE, B( K, K ), LDB,
+     $                        A( 1, K ), LDA )
+                  CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   30          CONTINUE
+            ELSE
+*
+*              Compute L'*A*L
+*
+               DO 40 K = 1, N, NB
+                  KB = MIN( N-K+1, NB )
+*
+*                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
+*
+                  CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
+     $                        KB, K-1, CONE, B, LDB, A( K, 1 ), LDA )
+                  CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, CONE, A( K, 1 ),
+     $                        LDA )
+                  CALL ZHER2K( UPLO, 'Conjugate transpose', K-1, KB,
+     $                         CONE, A( K, 1 ), LDA, B( K, 1 ), LDB,
+     $                         ONE, A, LDA )
+                  CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+     $                        LDA, B( K, 1 ), LDB, CONE, A( K, 1 ),
+     $                        LDA )
+                  CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose',
+     $                        'Non-unit', KB, K-1, CONE, B( K, K ), LDB,
+     $                        A( K, 1 ), LDA )
+                  CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+     $                         B( K, K ), LDB, INFO )
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZHEGST
+*
+      END
diff --git a/SRC/zhegv.f b/SRC/zhegv.f
new file mode 100644
index 00000000..ded1b580
--- /dev/null
+++ b/SRC/zhegv.f
@@ -0,0 +1,232 @@
+      SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, 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, ITYPE, LDA, LDB, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEGV computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian 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.
+*
+*  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
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**H*B*Z = I;
+*          if ITYPE = 3, Z**H*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  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 Hermitian positive definite matrix B.
+*          If UPLO = 'U', the leading N-by-N upper triangular part of B
+*          contains the upper triangular part of the matrix B.
+*          If UPLO = 'L', the leading N-by-N lower triangular part of B
+*          contains the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**H*U or B = L*L**H.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= 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:  ZPOTRF or ZHEEV returned an error code:
+*             <= N:  if INFO = i, ZHEEV 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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKOPT, NB, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHEEV, ZHEGST, ZPOTRF, ZTRMM, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         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 ) THEN
+            INFO = -11
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEGV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL ZPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, 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 = 'C'
+            END IF
+*
+            CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZHEGV
+*
+      END
diff --git a/SRC/zhegvd.f b/SRC/zhegvd.f
new file mode 100644
index 00000000..b5b72ca3
--- /dev/null
+++ b/SRC/zhegvd.f
@@ -0,0 +1,307 @@
+      SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+     $                   LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, LDA, LDB, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian and B is also positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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.
+*
+*  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
+*          matrix Z of eigenvectors.  The eigenvectors are normalized
+*          as follows:
+*          if ITYPE = 1 or 2, Z**H*B*Z = I;
+*          if ITYPE = 3, Z**H*inv(B)*Z = I.
+*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+*          or the lower triangle (if UPLO='L') of A, including the
+*          diagonal, is destroyed.
+*
+*  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 Hermitian matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**H*U or B = L*L**H.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= 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.
+*          If N <= 1,                LWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LWORK >= N + 1.
+*          If JOBZ  = 'V' and N > 1, LWORK >= 2*N + N**2.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of the array RWORK.
+*          If N <= 1,                LRWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LRWORK >= N.
+*          If JOBZ  = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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.
+*          If N <= 1,                LIWORK >= 1.
+*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  ZPOTRF or ZHEEVD returned an error code:
+*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm
+*                    failed to converge; i off-diagonal elements of an
+*                    intermediate tridiagonal form did not converge to
+*                    zero;
+*                    if INFO = i and JOBZ = 'V', then the algorithm
+*                    failed to compute an eigenvalue while working on
+*                    the submatrix lying in rows and columns INFO/(N+1)
+*                    through mod(INFO,N+1);
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  Modified so that no backsubstitution is performed if ZHEEVD fails to
+*  converge (NEIG in old code could be greater than N causing out of
+*  bounds reference to A - reported by Ralf Meyer).  Also corrected the
+*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LIOPT, LIWMIN, LOPT, LROPT, LRWMIN, LWMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHEEVD, ZHEGST, ZPOTRF, ZTRMM, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( N.LE.1 ) THEN
+         LWMIN = 1
+         LRWMIN = 1
+         LIWMIN = 1
+      ELSE IF( WANTZ ) THEN
+         LWMIN = 2*N + N*N
+         LRWMIN = 1 + 5*N + 2*N*N
+         LIWMIN = 3 + 5*N
+      ELSE
+         LWMIN = N + 1
+         LRWMIN = N
+         LIWMIN = 1
+      END IF
+      LOPT = LWMIN
+      LROPT = LRWMIN
+      LIOPT = LIWMIN
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LOPT
+         RWORK( 1 ) = LROPT
+         IWORK( 1 ) = LIOPT
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL ZPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK,
+     $             IWORK, LIWORK, INFO )
+      LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) )
+      LROPT = MAX( DBLE( LROPT ), DBLE( RWORK( 1 ) ) )
+      LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) )
+*
+      IF( WANTZ .AND. INFO.EQ.0 ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, CONE,
+     $                  B, LDB, A, LDA )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, CONE,
+     $                  B, LDB, A, LDA )
+         END IF
+      END IF
+*
+      WORK( 1 ) = LOPT
+      RWORK( 1 ) = LROPT
+      IWORK( 1 ) = LIOPT
+*
+      RETURN
+*
+*     End of ZHEGVD
+*
+      END
diff --git a/SRC/zhegvx.f b/SRC/zhegvx.f
new file mode 100644
index 00000000..f810c412
--- /dev/null
+++ b/SRC/zhegvx.f
@@ -0,0 +1,336 @@
+      SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB,
+     $                   VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK,
+     $                   LWORK, RWORK, IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEGVX computes selected eigenvalues, and optionally, eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian and B is also positive definite.
+*  Eigenvalues and eigenvectors can be selected by specifying either a
+*  range of values or a range of indices for the desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+**
+*  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.
+*
+*  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,  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).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)
+*          On entry, the Hermitian matrix B.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of B contains the
+*          upper triangular part of the matrix B.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of B contains
+*          the lower triangular part of the matrix B.
+*
+*          On exit, if INFO <= N, the part of B containing the matrix is
+*          overwritten by the triangular factor U or L from the Cholesky
+*          factorization B = U**H*U or B = L*L**H.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing A to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,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 length of the array WORK.  LWORK >= max(1,2*N).
+*          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 (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  ZPOTRF or ZHEEVX returned an error code:
+*             <= N:  if INFO = i, ZHEEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHEEVX, ZHEGST, ZPOTRF, ZTRMM, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -11
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -13
+            END IF
+         END IF
+      END IF
+      IF (INFO.EQ.0) THEN
+         IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         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 ) .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEGVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL ZPOTRF( UPLO, N, B, LDB, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+      CALL ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
+     $             M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL,
+     $             INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
+     $                  LDB, Z, LDZ )
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B,
+     $                  LDB, Z, LDZ )
+         END IF
+      END IF
+*
+*     Set WORK(1) to optimal complex workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZHEGVX
+*
+      END
diff --git a/SRC/zherfs.f b/SRC/zherfs.f
new file mode 100644
index 00000000..6d5afca9
--- /dev/null
+++ b/SRC/zherfs.f
@@ -0,0 +1,343 @@
+      SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, 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          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHERFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian indefinite, and
+*  provides error bounds and backward error estimates for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)
+*          The factored form of the matrix A.  AF contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**H or
+*          A = L*D*L**H as computed by ZHETRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZHETRF.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZHETRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZHEMV, ZHETRS, ZLACN2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHERFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZHEMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( A( K, K ) ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( A( K, K ) ) )*XK
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZHETRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZHETRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZHETRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZHERFS
+*
+      END
diff --git a/SRC/zhesv.f b/SRC/zhesv.f
new file mode 100644
index 00000000..0d661b48
--- /dev/null
+++ b/SRC/zhesv.f
@@ -0,0 +1,174 @@
+      SUBROUTINE ZHESV( 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( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHESV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**H,  if UPLO = 'U', or
+*     A = L * D * L**H,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is Hermitian 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) 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 block diagonal matrix D and the
+*          multipliers used to obtain the factor U or L from the
+*          factorization A = U*D*U**H or A = L*D*L**H as computed by
+*          ZHETRF.
+*
+*  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 ZHETRF.  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) COMPLEX*16 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) COMPLEX*16 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
+*          ZHETRF.
+*
+*          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           XERBLA, ZHETRF, ZHETRS
+*     ..
+*     .. 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, 'ZHETRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHESV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZHESV
+*
+      END
diff --git a/SRC/zhesvx.f b/SRC/zhesvx.f
new file mode 100644
index 00000000..e41b732b
--- /dev/null
+++ b/SRC/zhesvx.f
@@ -0,0 +1,300 @@
+      SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+     $                   LDB, X, LDX, RCOND, FERR, BERR, 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          FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHESVX uses the diagonal pivoting factorization to compute the
+*  solution to a complex system of linear equations A * X = B,
+*  where A is an N-by-N Hermitian 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 = 'N', the diagonal pivoting method is used to factor A.
+*     The form of the factorization is
+*        A = U * D * U**H,  if UPLO = 'U', or
+*        A = L * D * L**H,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices, and D is Hermitian and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AF and IPIV contain the factored form
+*                  of A.  A, AF and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by ZHETRF.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H.
+*
+*  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 details of the interchanges and the block structure
+*          of D, as determined by ZHETRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by ZHETRF.
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  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.  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) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= max(1,2*N), and for best
+*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
+*          NB is the optimal blocksize for ZHETRF.
+*
+*          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
+*          > 0: if INFO = i, and i is
+*                <= N:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOFACT
+      INTEGER            LWKOPT, NB
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANHE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANHE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHECON, ZHERFS, ZHETRF, ZHETRS, ZLACPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKOPT = MAX( 1, 2*N )
+         IF( NOFACT ) THEN
+            NB = ILAENV( 1, 'ZHETRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = MAX( LWKOPT, N*NB )
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHESVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL ZHETRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANHE( 'I', UPLO, N, A, LDA, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZHECON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZHETRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZHESVX
+*
+      END
diff --git a/SRC/zhetd2.f b/SRC/zhetd2.f
new file mode 100644
index 00000000..24b0a1df
--- /dev/null
+++ b/SRC/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/zhetf2.f b/SRC/zhetf2.f
new file mode 100644
index 00000000..67ea49d7
--- /dev/null
+++ b/SRC/zhetf2.f
@@ -0,0 +1,553 @@
+      SUBROUTINE ZHETF2( 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( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHETF2 computes the factorization of a complex Hermitian 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 conjugate transpose of U, and D is
+*  Hermitian 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
+*          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, 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.210 and l.393
+*         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
+*
+*  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, D, D11, D22, R1, ROWMAX,
+     $                   TT
+      COMPLEX*16         D12, D21, T, WK, WKM1, WKP1, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, DISNAN
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAPY2
+      EXTERNAL           LSAME, IZAMAX, DLAPY2, DISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZHER, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'ZHETF2', -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 90
+         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( DBLE( 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 = IZAMAX( K-1, A( 1, K ), 1 )
+            COLMAX = CABS1( 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
+            A( K, K ) = DBLE( A( K, 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 + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( DBLE( 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 ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+               DO 20 J = KP + 1, KK - 1
+                  T = DCONJG( A( J, KK ) )
+                  A( J, KK ) = DCONJG( A( KP, J ) )
+                  A( KP, J ) = T
+   20          CONTINUE
+               A( KP, KK ) = DCONJG( A( KP, KK ) )
+               R1 = DBLE( A( KK, KK ) )
+               A( KK, KK ) = DBLE( A( KP, KP ) )
+               A( KP, KP ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  A( K, K ) = DBLE( A( K, K ) )
+                  T = A( K-1, K )
+                  A( K-1, K ) = A( KP, K )
+                  A( KP, K ) = T
+               END IF
+            ELSE
+               A( K, K ) = DBLE( A( K, K ) )
+               IF( KSTEP.EQ.2 )
+     $            A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) )
+            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 / DBLE( A( K, K ) )
+               CALL ZHER( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+*              Store U(k) in column k
+*
+               CALL ZDSCAL( 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
+*
+                  D = DLAPY2( DBLE( A( K-1, K ) ),
+     $                DIMAG( A( K-1, K ) ) )
+                  D22 = DBLE( A( K-1, K-1 ) ) / D
+                  D11 = DBLE( A( K, K ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D12 = A( K-1, K ) / D
+                  D = TT / D
+*
+                  DO 40 J = K - 2, 1, -1
+                     WKM1 = D*( D11*A( J, K-1 )-DCONJG( D12 )*
+     $                      A( J, K ) )
+                     WK = D*( D22*A( J, K )-D12*A( J, K-1 ) )
+                     DO 30 I = J, 1, -1
+                        A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) -
+     $                              A( I, K-1 )*DCONJG( WKM1 )
+   30                CONTINUE
+                     A( J, K ) = WK
+                     A( J, K-1 ) = WKM1
+                     A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 )
+   40             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
+   50    CONTINUE
+*
+*        If K > N, exit from loop
+*
+         IF( K.GT.N )
+     $      GO TO 90
+         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( DBLE( 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 + IZAMAX( N-K, A( K+1, K ), 1 )
+            COLMAX = CABS1( 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
+            A( K, K ) = DBLE( A( K, 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 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( DBLE( 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 ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+               DO 60 J = KK + 1, KP - 1
+                  T = DCONJG( A( J, KK ) )
+                  A( J, KK ) = DCONJG( A( KP, J ) )
+                  A( KP, J ) = T
+   60          CONTINUE
+               A( KP, KK ) = DCONJG( A( KP, KK ) )
+               R1 = DBLE( A( KK, KK ) )
+               A( KK, KK ) = DBLE( A( KP, KP ) )
+               A( KP, KP ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  A( K, K ) = DBLE( A( K, K ) )
+                  T = A( K+1, K )
+                  A( K+1, K ) = A( KP, K )
+                  A( KP, K ) = T
+               END IF
+            ELSE
+               A( K, K ) = DBLE( A( K, K ) )
+               IF( KSTEP.EQ.2 )
+     $            A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) )
+            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 / DBLE( A( K, K ) )
+                  CALL ZHER( UPLO, N-K, -R1, A( K+1, K ), 1,
+     $                       A( K+1, K+1 ), LDA )
+*
+*                 Store L(k) in column K
+*
+                  CALL ZDSCAL( N-K, R1, 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 - ( 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) )'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D = DLAPY2( DBLE( A( K+1, K ) ),
+     $                DIMAG( A( K+1, K ) ) )
+                  D11 = DBLE( A( K+1, K+1 ) ) / D
+                  D22 = DBLE( A( K, K ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D21 = A( K+1, K ) / D
+                  D = TT / D
+*
+                  DO 80 J = K + 2, N
+                     WK = D*( D11*A( J, K )-D21*A( J, K+1 ) )
+                     WKP1 = D*( D22*A( J, K+1 )-DCONJG( D21 )*
+     $                      A( J, K ) )
+                     DO 70 I = J, N
+                        A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) -
+     $                              A( I, K+1 )*DCONJG( WKP1 )
+   70                CONTINUE
+                     A( J, K ) = WK
+                     A( J, K+1 ) = WKP1
+                     A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 )
+   80             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 50
+*
+      END IF
+*
+   90 CONTINUE
+      RETURN
+*
+*     End of ZHETF2
+*
+      END
diff --git a/SRC/zhetrd.f b/SRC/zhetrd.f
new file mode 100644
index 00000000..fb0cd0b2
--- /dev/null
+++ b/SRC/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/zhetrf.f b/SRC/zhetrf.f
new file mode 100644
index 00000000..173d0766
--- /dev/null
+++ b/SRC/zhetrf.f
@@ -0,0 +1,281 @@
+      SUBROUTINE ZHETRF( 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( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHETRF computes the factorization of a complex Hermitian matrix A
+*  using the Bunch-Kaufman diagonal pivoting method.  The form of the
+*  factorization is
+*
+*     A = U*D*U**H  or  A = L*D*L**H
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is Hermitian 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) 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, 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) COMPLEX*16 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.
+*
+*  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           XERBLA, ZHETF2, ZLAHEF
+*     ..
+*     .. 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, 'ZHETRF', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHETRF', -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, 'ZHETRF', 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 ZLAHEF;
+*        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 ZLAHEF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns 1:k of A
+*
+            CALL ZHETF2( 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 ZLAHEF;
+*        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 ZLAHEF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+     $                   WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns k:n of A
+*
+            CALL ZHETF2( 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 ZHETRF
+*
+      END
diff --git a/SRC/zhetri.f b/SRC/zhetri.f
new file mode 100644
index 00000000..0cc08941
--- /dev/null
+++ b/SRC/zhetri.f
@@ -0,0 +1,327 @@
+      SUBROUTINE ZHETRI( 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( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHETRI computes the inverse of a complex Hermitian indefinite matrix
+*  A using the factorization A = U*D*U**H or A = L*D*L**H computed by
+*  ZHETRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 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 ZHETRF.
+*
+*          On exit, if INFO = 0, the (Hermitian) 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 ZHETRF.
+*
+*  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
+*          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*               inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      COMPLEX*16         CONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KP, KSTEP
+      DOUBLE PRECISION   AK, AKP1, D, T
+      COMPLEX*16         AKKP1, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZHEMV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, 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( 'ZHETRI', -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 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            A( K, K ) = ONE / DBLE( A( K, K ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - DBLE( ZDOTC( 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 = DBLE( A( K, K ) ) / T
+            AKP1 = DBLE( 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 ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1,
+     $                     K ), 1 ) )
+               A( K, K+1 ) = A( K, K+1 ) -
+     $                       ZDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+               CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+               CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K+1 ), 1 )
+               A( K+1, K+1 ) = A( K+1, K+1 ) -
+     $                         DBLE( ZDOTC( 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 ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+            DO 40 J = KP + 1, K - 1
+               TEMP = DCONJG( A( J, K ) )
+               A( J, K ) = DCONJG( A( KP, J ) )
+               A( KP, J ) = TEMP
+   40       CONTINUE
+            A( KP, K ) = DCONJG( A( KP, K ) )
+            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
+   50    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
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            A( K, K ) = ONE / DBLE( A( K, K ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+     $                     1, ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - DBLE( ZDOTC( 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 = DBLE( A( K-1, K-1 ) ) / T
+            AKP1 = DBLE( 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 ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK,
+     $                     1, ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1,
+     $                     A( K+1, K ), 1 ) )
+               A( K, K-1 ) = A( K, K-1 ) -
+     $                       ZDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+     $                       1 )
+               CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+               CALL ZHEMV( UPLO, N-K, -CONE, 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 ) -
+     $                         DBLE( ZDOTC( 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 ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+            DO 70 J = K + 1, KP - 1
+               TEMP = DCONJG( A( J, K ) )
+               A( J, K ) = DCONJG( A( KP, J ) )
+               A( KP, J ) = TEMP
+   70       CONTINUE
+            A( KP, K ) = DCONJG( A( KP, K ) )
+            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 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHETRI
+*
+      END
diff --git a/SRC/zhetrs.f b/SRC/zhetrs.f
new file mode 100644
index 00000000..2e49a51a
--- /dev/null
+++ b/SRC/zhetrs.f
@@ -0,0 +1,393 @@
+      SUBROUTINE ZHETRS( 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( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHETRS solves a system of linear equations A*X = B with a complex
+*  Hermitian matrix A using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by ZHETRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  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 block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZHETRF.
+*
+*  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 ZHETRF.
+*
+*  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            UPPER
+      INTEGER            J, K, KP
+      DOUBLE PRECISION   S
+      COMPLEX*16         AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZGEMV, ZGERU, ZLACGV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCONJG, 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( 'ZHETRS', -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 ZSWAP( 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 ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            S = DBLE( ONE ) / DBLE( A( K, K ) )
+            CALL ZDSCAL( NRHS, S, 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 ZSWAP( 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 ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL ZGERU( 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 ) / DCONJG( AKM1K )
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / DCONJG( 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.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZSWAP( 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 ZGERU( 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.
+*
+            S = DBLE( ONE ) / DBLE( A( K, K ) )
+            CALL ZDSCAL( NRHS, S, 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 ZSWAP( 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 ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL ZGERU( 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 ) / DCONJG( AKM1K )
+            AK = A( K+1, K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / DCONJG( 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 ) THEN
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE,
+     $                     B( K-1, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHETRS
+*
+      END
diff --git a/SRC/zhgeqz.f b/SRC/zhgeqz.f
new file mode 100644
index 00000000..6a9403bd
--- /dev/null
+++ b/SRC/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/zhpcon.f b/SRC/zhpcon.f
new file mode 100644
index 00000000..5b30e756
--- /dev/null
+++ b/SRC/zhpcon.f
@@ -0,0 +1,159 @@
+      SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, 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          UPLO
+      INTEGER            INFO, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPCON estimates the reciprocal of the condition number of a complex
+*  Hermitian packed matrix A using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by ZHPTRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZHPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZHPTRF.
+*
+*  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) COMPLEX*16 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            UPPER
+      INTEGER            I, IP, KASE
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHPTRS, ZLACN2
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         IP = N*( N+1 ) / 2
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP - I
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         IP = 1
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP + N - I + 1
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL ZHPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of ZHPCON
+*
+      END
diff --git a/SRC/zhpev.f b/SRC/zhpev.f
new file mode 100644
index 00000000..896d9d3a
--- /dev/null
+++ b/SRC/zhpev.f
@@ -0,0 +1,196 @@
+      SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, 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, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
+*  complex Hermitian matrix 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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX*16 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) COMPLEX*16 array, dimension (max(1, 2*N-1))
+*
+*  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 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
+     $                   ISCALE
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHP
+      EXTERNAL           LSAME, DLAMCH, ZLANHP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEQR,
+     $                   ZUPGTR
+*     ..
+*     .. 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, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          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( 'ZHPEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         RWORK( 1 ) = 1
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = ZLANHP( 'M', UPLO, N, AP, 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 ) THEN
+         CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
+     $             IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     ZUPGTR to generate the orthogonal matrix, then call ZSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         INDWRK = INDTAU + N
+         CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+         INDRWK = INDE + N
+         CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ,
+     $                RWORK( INDRWK ), 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 ZHPEV
+*
+      END
diff --git a/SRC/zhpevd.f b/SRC/zhpevd.f
new file mode 100644
index 00000000..614a5ea6
--- /dev/null
+++ b/SRC/zhpevd.f
@@ -0,0 +1,286 @@
+      SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
+     $                   RWORK, LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of
+*  a complex Hermitian matrix A in packed storage.  If eigenvectors are
+*  desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX*16 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/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of array WORK.
+*          If N <= 1,               LWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array,
+*                                         dimension (LRWORK)
+*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK must be at least 1.
+*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.
+*          If JOBZ = 'V' and N > 1, LRWORK must be at least
+*                    1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK,
+     $                   ISCALE, LIWMIN, LLRWK, LLWRK, LRWMIN, LWMIN
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHP
+      EXTERNAL           LSAME, DLAMCH, ZLANHP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEDC,
+     $                   ZUPMTR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LWMIN = 2*N
+               LRWMIN = 1 + 5*N + 2*N**2
+               LIWMIN = 3 + 5*N
+            ELSE
+               LWMIN = N
+               LRWMIN = N
+               LIWMIN = 1
+            END IF
+         END IF
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -9
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPEVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = 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 = ZLANHP( 'M', UPLO, N, AP, 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 ) THEN
+         CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      INDRWK = INDE + N
+      INDWRK = INDTAU + N
+      LLWRK = LWORK - INDWRK + 1
+      LLRWK = LRWORK - INDRWK + 1
+      CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ),
+     $             IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     ZUPGTR to generate the orthogonal matrix, then call ZSTEDC.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL ZSTEDC( 'I', N, W, RWORK( INDE ), Z, LDZ, WORK( INDWRK ),
+     $                LLWRK, RWORK( INDRWK ), LLRWK, IWORK, LIWORK,
+     $                INFO )
+         CALL ZUPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of ZHPEVD
+*
+      END
diff --git a/SRC/zhpevx.f b/SRC/zhpevx.f
new file mode 100644
index 00000000..57bc2de0
--- /dev/null
+++ b/SRC/zhpevx.f
@@ -0,0 +1,388 @@
+      SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
+     $                   ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK,
+     $                   IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, IU, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPEVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex Hermitian matrix A in packed storage.
+*  Eigenvalues/vectors can be selected by specifying either a range of
+*  values or a range of indices for the desired eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*          See "Computing Small Singular Values of Bidiagonal Matrices
+*          with Guaranteed High Relative Accuracy," by Demmel and
+*          Kahan, LAPACK Working Note #3.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the selected eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and
+*          the index of the eigenvector is returned in IFAIL.
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, then i eigenvectors failed to converge.
+*                Their indices are stored in array IFAIL.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+      CHARACTER          ORDER
+      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+     $                   INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE,
+     $                   ITMP1, J, JJ, NSPLIT
+      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+     $                   SIGMA, SMLNUM, TMP1, VLL, VUU
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHP
+      EXTERNAL           LSAME, DLAMCH, ZLANHP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL,
+     $                   ZHPTRD, ZSTEIN, ZSTEQR, ZSWAP, ZUPGTR, ZUPMTR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL )
+     $         INFO = -7
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+               INFO = -8
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -9
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+     $      INFO = -14
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPEVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = AP( 1 )
+         ELSE
+            IF( VL.LT.DBLE( AP( 1 ) ) .AND. VU.GE.DBLE( AP( 1 ) ) ) THEN
+               M = 1
+               W( 1 ) = AP( 1 )
+            END IF
+         END IF
+         IF( WANTZ )
+     $      Z( 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 = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ISCALE = 0
+      ABSTLL = ABSTOL
+      IF( VALEIG ) THEN
+         VLL = VL
+         VUU = VU
+      ELSE
+         VLL = ZERO
+         VUU = ZERO
+      END IF
+      ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK )
+      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 ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+         IF( ABSTOL.GT.0 )
+     $      ABSTLL = ABSTOL*SIGMA
+         IF( VALEIG ) THEN
+            VLL = VL*SIGMA
+            VUU = VU*SIGMA
+         END IF
+      END IF
+*
+*     Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form.
+*
+      INDD = 1
+      INDE = INDD + N
+      INDRWK = INDE + N
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      CALL ZHPTRD( UPLO, N, AP, RWORK( INDD ), RWORK( INDE ),
+     $             WORK( INDTAU ), IINFO )
+*
+*     If all eigenvalues are desired and ABSTOL is less than or equal
+*     to zero, then call DSTERF or ZUPGTR and ZSTEQR.  If this fails
+*     for some eigenvalue, then try DSTEBZ.
+*
+      TEST = .FALSE.
+      IF (INDEIG) THEN
+         IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+            TEST = .TRUE.
+         END IF
+      END IF
+      IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+         CALL DCOPY( N, RWORK( INDD ), 1, W, 1 )
+         INDEE = INDRWK + 2*N
+         IF( .NOT.WANTZ ) THEN
+            CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL DSTERF( N, W, RWORK( INDEE ), INFO )
+         ELSE
+            CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                   WORK( INDWRK ), IINFO )
+            CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 )
+            CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ,
+     $                   RWORK( INDRWK ), INFO )
+            IF( INFO.EQ.0 ) THEN
+               DO 10 I = 1, N
+                  IFAIL( I ) = 0
+   10          CONTINUE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            M = N
+            GO TO 20
+         END IF
+         INFO = 0
+      END IF
+*
+*     Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.
+*
+      IF( WANTZ ) THEN
+         ORDER = 'B'
+      ELSE
+         ORDER = 'E'
+      END IF
+      INDIBL = 1
+      INDISP = INDIBL + N
+      INDIWK = INDISP + N
+      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+     $             RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W,
+     $             IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ),
+     $             IWORK( INDIWK ), INFO )
+*
+      IF( WANTZ ) THEN
+         CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W,
+     $                IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+     $                RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO )
+*
+*        Apply unitary matrix used in reduction to tridiagonal
+*        form to eigenvectors returned by ZSTEIN.
+*
+         INDWRK = INDTAU + N
+         CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+   20 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = M
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in order, then sort them, along with
+*     eigenvectors.
+*
+      IF( WANTZ ) THEN
+         DO 40 J = 1, M - 1
+            I = 0
+            TMP1 = W( J )
+            DO 30 JJ = J + 1, M
+               IF( W( JJ ).LT.TMP1 ) THEN
+                  I = JJ
+                  TMP1 = W( JJ )
+               END IF
+   30       CONTINUE
+*
+            IF( I.NE.0 ) THEN
+               ITMP1 = IWORK( INDIBL+I-1 )
+               W( I ) = W( J )
+               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+               W( J ) = TMP1
+               IWORK( INDIBL+J-1 ) = ITMP1
+               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+               IF( INFO.NE.0 ) THEN
+                  ITMP1 = IFAIL( I )
+                  IFAIL( I ) = IFAIL( J )
+                  IFAIL( J ) = ITMP1
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHPEVX
+*
+      END
diff --git a/SRC/zhpgst.f b/SRC/zhpgst.f
new file mode 100644
index 00000000..2a9fca87
--- /dev/null
+++ b/SRC/zhpgst.f
@@ -0,0 +1,215 @@
+      SUBROUTINE ZHPGST( 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 ..
+      COMPLEX*16         AP( * ), BP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPGST reduces a complex Hermitian-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**H)*A*inv(U) or inv(L)*A*inv(L**H)
+*
+*  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**H or L**H*A*L.
+*
+*  B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
+*          = 2 or 3: compute U*A*U**H or L**H*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored and B is factored as
+*                  U**H*U;
+*          = 'L':  Lower triangle of A is stored and B is factored as
+*                  L*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX*16 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 ZPPTRF.
+*
+*  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.0D+0, HALF = 0.5D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
+      DOUBLE PRECISION   AJJ, AKK, BJJ, BKK
+      COMPLEX*16         CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZDSCAL, ZHPMV, ZHPR2, ZTPMV,
+     $                   ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. 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( 'ZHPGST', -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
+*
+               AP( JJ ) = DBLE( AP( JJ ) )
+               BJJ = BP( JJ )
+               CALL ZTPSV( UPLO, 'Conjugate transpose', 'Non-unit', J,
+     $                     BP, AP( J1 ), 1 )
+               CALL ZHPMV( UPLO, J-1, -CONE, AP, BP( J1 ), 1, CONE,
+     $                     AP( J1 ), 1 )
+               CALL ZDSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
+               AP( JJ ) = ( AP( JJ )-ZDOTC( 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 ZDSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
+                  CT = -HALF*AKK
+                  CALL ZAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL ZHPR2( UPLO, N-K, -CONE, AP( KK+1 ), 1,
+     $                        BP( KK+1 ), 1, AP( K1K1 ) )
+                  CALL ZAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL ZTPSV( 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 ZTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
+     $                     AP( K1 ), 1 )
+               CT = HALF*AKK
+               CALL ZAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL ZHPR2( UPLO, K-1, CONE, AP( K1 ), 1, BP( K1 ), 1,
+     $                     AP )
+               CALL ZAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL ZDSCAL( 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 + ZDOTC( N-J, AP( JJ+1 ), 1,
+     $                    BP( JJ+1 ), 1 )
+               CALL ZDSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
+               CALL ZHPMV( UPLO, N-J, CONE, AP( J1J1 ), BP( JJ+1 ), 1,
+     $                     CONE, AP( JJ+1 ), 1 )
+               CALL ZTPMV( UPLO, 'Conjugate transpose', 'Non-unit',
+     $                     N-J+1, BP( JJ ), AP( JJ ), 1 )
+               JJ = J1J1
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZHPGST
+*
+      END
diff --git a/SRC/zhpgv.f b/SRC/zhpgv.f
new file mode 100644
index 00000000..5cc78079
--- /dev/null
+++ b/SRC/zhpgv.f
@@ -0,0 +1,196 @@
+      SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                  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, ITYPE, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPGV computes all the eigenvalues and, optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian, 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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage
+*          format as B.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 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**H*B*Z = I;
+*          if ITYPE = 3, Z**H*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) COMPLEX*16 array, dimension (max(1, 2*N-1))
+*
+*  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:  ZPPTRF or ZHPEV returned an error code:
+*             <= N:  if INFO = i, ZHPEV failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not convergeto 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           XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
+*     ..
+*     .. 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( 'ZHPGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL ZPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, 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 = 'C'
+            END IF
+*
+            DO 10 J = 1, NEIG
+               CALL ZTPSV( 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 = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, NEIG
+               CALL ZTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZHPGV
+*
+      END
diff --git a/SRC/zhpgvd.f b/SRC/zhpgvd.f
new file mode 100644
index 00000000..b50538c9
--- /dev/null
+++ b/SRC/zhpgvd.f
@@ -0,0 +1,295 @@
+      SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                   LWORK, RWORK, LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian, stored in packed format, and B is also
+*  positive definite.
+*  If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+*  The divide and conquer algorithm makes very mild assumptions about
+*  floating point arithmetic. It will work on machines with a guard
+*  digit in add/subtract, or on those binary machines without guard
+*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+*  Cray-2. It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage
+*          format as B.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 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**H*B*Z = I;
+*          if ITYPE = 3, Z**H*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) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of array WORK.
+*          If N <= 1,               LWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LWORK >= N.
+*          If JOBZ = 'V' and N > 1, LWORK >= 2*N.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the required sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of array RWORK.
+*          If N <= 1,               LRWORK >= 1.
+*          If JOBZ = 'N' and N > 1, LRWORK >= N.
+*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of array IWORK.
+*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
+*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the required sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  ZPPTRF or ZHPEVD returned an error code:
+*             <= N:  if INFO = i, ZHPEVD failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not convergeto 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.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J, LIWMIN, LRWMIN, LWMIN, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 1
+         ELSE
+            IF( WANTZ ) THEN
+               LWMIN = 2*N
+               LRWMIN = 1 + 5*N + 2*N**2
+               LIWMIN = 3 + 5*N
+            ELSE
+               LWMIN = N
+               LRWMIN = N
+               LIWMIN = 1
+            END IF
+         END IF
+*
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -11
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPGVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL ZPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK,
+     $             LRWORK, IWORK, LIWORK, INFO )
+      LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) )
+      LRWMIN = MAX( DBLE( LRWMIN ), DBLE( RWORK( 1 ) ) )
+      LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            DO 10 J = 1, NEIG
+               CALL ZTPSV( 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 = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, NEIG
+               CALL ZTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of ZHPGVD
+*
+      END
diff --git a/SRC/zhpgvx.f b/SRC/zhpgvx.f
new file mode 100644
index 00000000..bdbc69ae
--- /dev/null
+++ b/SRC/zhpgvx.f
@@ -0,0 +1,293 @@
+      SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
+     $                   IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE, UPLO
+      INTEGER            IL, INFO, ITYPE, IU, LDZ, M, N
+      DOUBLE PRECISION   ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IFAIL( * ), IWORK( * )
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         AP( * ), BP( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPGVX computes selected eigenvalues and, optionally, eigenvectors
+*  of a complex generalized Hermitian-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 Hermitian, stored in packed format, and B is also
+*  positive definite.  Eigenvalues and eigenvectors can be selected by
+*  specifying either a range of values or a range of indices for the
+*  desired eigenvalues.
+*
+*  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.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found;
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found;
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or B = L*L**H, in the same storage
+*          format as B.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          The absolute error tolerance for the eigenvalues.
+*          An approximate eigenvalue is accepted as converged
+*          when it is determined to lie in an interval [a,b]
+*          of width less than or equal to
+*
+*                  ABSTOL + EPS *   max( |a|,|b| ) ,
+*
+*          where EPS is the machine precision.  If ABSTOL is less than
+*          or equal to zero, then  EPS*|T|  will be used in its place,
+*          where |T| is the 1-norm of the tridiagonal matrix obtained
+*          by reducing AP to tridiagonal form.
+*
+*          Eigenvalues will be computed most accurately when ABSTOL is
+*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*          If this routine returns with INFO>0, indicating that some
+*          eigenvectors did not converge, try setting ABSTOL to
+*          2*DLAMCH('S').
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          On normal exit, the first M elements contain the selected
+*          eigenvalues in ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)
+*          If JOBZ = 'N', then Z is not referenced.
+*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix A
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**H*B*Z = I;
+*          if ITYPE = 3, Z**H*inv(B)*Z = I.
+*
+*          If an eigenvector fails to converge, then that column of Z
+*          contains the latest approximation to the eigenvector, and the
+*          index of the eigenvector is returned in IFAIL.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (5*N)
+*
+*  IFAIL   (output) INTEGER array, dimension (N)
+*          If JOBZ = 'V', then if INFO = 0, the first M elements of
+*          IFAIL are zero.  If INFO > 0, then IFAIL contains the
+*          indices of the eigenvectors that failed to converge.
+*          If JOBZ = 'N', then IFAIL is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  ZPPTRF or ZHPEVX returned an error code:
+*             <= N:  if INFO = i, ZHPEVX failed to converge;
+*                    i eigenvectors failed to converge.  Their indices
+*                    are stored in array IFAIL.
+*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE 
+         IF( VALEIG ) THEN
+            IF( N.GT.0 .AND. VU.LE.VL ) THEN
+               INFO = -9
+            END IF
+         ELSE IF( INDEIG ) THEN
+            IF( IL.LT.1 ) THEN
+               INFO = -10
+            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+               INFO = -11
+            END IF
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPGVX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL ZPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
+     $             W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         IF( INFO.GT.0 )
+     $      M = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'C'
+            END IF
+*
+            DO 10 J = 1, M
+               CALL ZTPSV( 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 = 'C'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, M
+               CALL ZTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZHPGVX
+*
+      END
diff --git a/SRC/zhprfs.f b/SRC/zhprfs.f
new file mode 100644
index 00000000..a2f8df9b
--- /dev/null
+++ b/SRC/zhprfs.f
@@ -0,0 +1,341 @@
+      SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
+     $                   FERR, BERR, 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          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian indefinite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian 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.
+*
+*  AFP     (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The factored form of the matrix A.  AFP contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**H or
+*          A = L*D*L**H as computed by ZHPTRF, stored as a packed
+*          triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZHPTRF.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZHPTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZHPMV, ZHPTRS, ZLACN2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZHPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( AP( KK+K-1 ) ) )*
+     $                      XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( AP( KK ) ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZHPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZHPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZHPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZHPRFS
+*
+      END
diff --git a/SRC/zhpsv.f b/SRC/zhpsv.f
new file mode 100644
index 00000000..abdb122e
--- /dev/null
+++ b/SRC/zhpsv.f
@@ -0,0 +1,148 @@
+      SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian matrix stored in packed format and X
+*  and B are N-by-NRHS matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**H,  if UPLO = 'U', or
+*     A = L * D * L**H,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, D is Hermitian 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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by ZHPTRF.  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) COMPLEX*16 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).
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHPTRF, ZHPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL ZHPTRF( UPLO, N, AP, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of ZHPSV
+*
+      END
diff --git a/SRC/zhpsvx.f b/SRC/zhpsvx.f
new file mode 100644
index 00000000..cdf67346
--- /dev/null
+++ b/SRC/zhpsvx.f
@@ -0,0 +1,277 @@
+      SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
+     $                   LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or
+*  A = L*D*L**H to compute the solution to a complex system of linear
+*  equations A * X = B, where A is an N-by-N Hermitian matrix stored
+*  in packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+*        A = U * D * U**H,  if UPLO = 'U', or
+*        A = L * D * L**H,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices and D is Hermitian and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AFP and IPIV contain the factored form of
+*                  A.  AFP and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*  AFP     (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains details of the interchanges and the block structure
+*          of D, as determined by ZHPTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by ZHPTRF.
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  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.  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHP
+      EXTERNAL           LSAME, DLAMCH, ZLANHP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRS,
+     $                   ZLACPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL ZCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL ZHPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANHP( 'I', UPLO, N, AP, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZHPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZHPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZHPSVX
+*
+      END
diff --git a/SRC/zhptrd.f b/SRC/zhptrd.f
new file mode 100644
index 00000000..9a554ae9
--- /dev/null
+++ b/SRC/zhptrd.f
@@ -0,0 +1,237 @@
+      SUBROUTINE ZHPTRD( 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   D( * ), E( * )
+      COMPLEX*16         AP( * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPTRD reduces a complex Hermitian matrix A stored in packed form 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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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 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.
+*
+*  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 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 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 AP,
+*  overwriting A(i+2:n,i), and tau is stored in TAU(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, I1, I1I1, II
+      COMPLEX*16         ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE
+*     ..
+*     .. 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( 'ZHPTRD', -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
+         AP( I1+N-1 ) = DBLE( AP( I1+N-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)
+*
+            ALPHA = AP( I1+I-1 )
+            CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
+            E( I ) = ALPHA
+*
+            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 ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
+     $                     1 )
+*
+*              Compute  w := y - 1/2 * tau * (y'*v) * v
+*
+               ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 )
+               CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
+*
+            END IF
+            AP( I1+I-1 ) = E( I )
+            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
+         AP( 1 ) = DBLE( AP( 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)
+*
+            ALPHA = AP( II+1 )
+            CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
+            E( I ) = ALPHA
+*
+            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 ZHPMV( 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*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ),
+     $                 1 )
+               CALL ZAXPY( 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 ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
+     $                     AP( I1I1 ) )
+*
+            END IF
+            AP( II+1 ) = E( I )
+            D( I ) = AP( II )
+            TAU( I ) = TAUI
+            II = I1I1
+   20    CONTINUE
+         D( N ) = AP( II )
+      END IF
+*
+      RETURN
+*
+*     End of ZHPTRD
+*
+      END
diff --git a/SRC/zhptrf.f b/SRC/zhptrf.f
new file mode 100644
index 00000000..b91179e3
--- /dev/null
+++ b/SRC/zhptrf.f
@@ -0,0 +1,581 @@
+      SUBROUTINE ZHPTRF( 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( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPTRF computes the factorization of a complex Hermitian packed
+*  matrix A using the Bunch-Kaufman diagonal pivoting method:
+*
+*     A = U*D*U**H  or  A = L*D*L**H
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is Hermitian 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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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, D, D11, D22, R1, ROWMAX,
+     $                   TT
+      COMPLEX*16         D12, D21, T, WK, WKM1, WKP1, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAPY2
+      EXTERNAL           LSAME, IZAMAX, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZHPR, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'ZHPTRF', -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( DBLE( 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 = IZAMAX( K-1, AP( KC ), 1 )
+            COLMAX = CABS1( 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
+            AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) )
+         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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( AP( KX ) )
+                     JMAX = J
+                  END IF
+                  KX = KX + J
+   20          CONTINUE
+               KPC = ( IMAX-1 )*IMAX / 2 + 1
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IZAMAX( IMAX-1, AP( KPC ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( DBLE( 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 ZSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
+               KX = KPC + KP - 1
+               DO 30 J = KP + 1, KK - 1
+                  KX = KX + J - 1
+                  T = DCONJG( AP( KNC+J-1 ) )
+                  AP( KNC+J-1 ) = DCONJG( AP( KX ) )
+                  AP( KX ) = T
+   30          CONTINUE
+               AP( KX+KK-1 ) = DCONJG( AP( KX+KK-1 ) )
+               R1 = DBLE( AP( KNC+KK-1 ) )
+               AP( KNC+KK-1 ) = DBLE( AP( KPC+KP-1 ) )
+               AP( KPC+KP-1 ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) )
+                  T = AP( KC+K-2 )
+                  AP( KC+K-2 ) = AP( KC+KP-1 )
+                  AP( KC+KP-1 ) = T
+               END IF
+            ELSE
+               AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) )
+               IF( KSTEP.EQ.2 )
+     $            AP( KC-1 ) = DBLE( AP( KC-1 ) )
+            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 / DBLE( AP( KC+K-1 ) )
+               CALL ZHPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+*              Store U(k) in column k
+*
+               CALL ZDSCAL( 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
+*
+                  D = DLAPY2( DBLE( AP( K-1+( K-1 )*K / 2 ) ),
+     $                DIMAG( AP( K-1+( K-1 )*K / 2 ) ) )
+                  D22 = DBLE( AP( K-1+( K-2 )*( K-1 ) / 2 ) ) / D
+                  D11 = DBLE( AP( K+( K-1 )*K / 2 ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D12 = AP( K-1+( K-1 )*K / 2 ) / D
+                  D = TT / D
+*
+                  DO 50 J = K - 2, 1, -1
+                     WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
+     $                      DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) )
+                     WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12*
+     $                    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 )*DCONJG( WK ) -
+     $                     AP( I+( K-2 )*( K-1 ) / 2 )*DCONJG( WKM1 )
+   40                CONTINUE
+                     AP( J+( K-1 )*K / 2 ) = WK
+                     AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
+                     AP( J+( J-1 )*J / 2 ) = DCMPLX( DBLE( AP( J+( J-
+     $                                       1 )*J / 2 ) ), 0.0D+0 )
+   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( DBLE( 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 + IZAMAX( N-K, AP( KC+1 ), 1 )
+            COLMAX = CABS1( 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
+            AP( KC ) = DBLE( AP( KC ) )
+         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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( 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 + IZAMAX( N-IMAX, AP( KPC+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( DBLE( 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 ZSWAP( 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 = DCONJG( AP( KNC+J-KK ) )
+                  AP( KNC+J-KK ) = DCONJG( AP( KX ) )
+                  AP( KX ) = T
+   80          CONTINUE
+               AP( KNC+KP-KK ) = DCONJG( AP( KNC+KP-KK ) )
+               R1 = DBLE( AP( KNC ) )
+               AP( KNC ) = DBLE( AP( KPC ) )
+               AP( KPC ) = R1
+               IF( KSTEP.EQ.2 ) THEN
+                  AP( KC ) = DBLE( AP( KC ) )
+                  T = AP( KC+1 )
+                  AP( KC+1 ) = AP( KC+KP-K )
+                  AP( KC+KP-K ) = T
+               END IF
+            ELSE
+               AP( KC ) = DBLE( AP( KC ) )
+               IF( KSTEP.EQ.2 )
+     $            AP( KNC ) = DBLE( AP( KNC ) )
+            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 / DBLE( AP( KC ) )
+                  CALL ZHPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+     $                       AP( KC+N-K+1 ) )
+*
+*                 Store L(k) in column K
+*
+                  CALL ZDSCAL( 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) )'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D = DLAPY2( DBLE( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ),
+     $                DIMAG( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ) )
+                  D11 = DBLE( AP( K+1+K*( 2*N-K-1 ) / 2 ) ) / D
+                  D22 = DBLE( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D
+                  TT = ONE / ( D11*D22-ONE )
+                  D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D
+                  D = TT / D
+*
+                  DO 100 J = K + 2, N
+                     WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21*
+     $                    AP( J+K*( 2*N-K-1 ) / 2 ) )
+                     WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
+     $                      DCONJG( D21 )*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 )*DCONJG( WK ) - AP( I+K*( 2*N-K-1 ) / 2 )*
+     $                     DCONJG( WKP1 )
+   90                CONTINUE
+                     AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
+                     AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
+                     AP( J+( J-1 )*( 2*N-J ) / 2 )
+     $                  = DCMPLX( DBLE( AP( J+( J-1 )*( 2*N-J ) / 2 ) ),
+     $                  0.0D+0 )
+  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 ZHPTRF
+*
+      END
diff --git a/SRC/zhptri.f b/SRC/zhptri.f
new file mode 100644
index 00000000..b41b9b99
--- /dev/null
+++ b/SRC/zhptri.f
@@ -0,0 +1,343 @@
+      SUBROUTINE ZHPTRI( UPLO, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPTRI computes the inverse of a complex Hermitian indefinite matrix
+*  A in packed storage using the factorization A = U*D*U**H or
+*  A = L*D*L**H computed by ZHPTRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by ZHPTRF,
+*          stored as a packed triangular matrix.
+*
+*          On exit, if INFO = 0, the (Hermitian) inverse of the original
+*          matrix, stored as a packed triangular matrix. The j-th column
+*          of inv(A) is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+*          if UPLO = 'L',
+*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZHPTRF.
+*
+*  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
+*          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*               inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      COMPLEX*16         CONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+      DOUBLE PRECISION   AK, AKP1, D, T
+      COMPLEX*16         AKKP1, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZHPMV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG
+*     ..
+*     .. 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( 'ZHPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         KP = N*( N+1 ) / 2
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP - INFO
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         KP = 1
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP + N - INFO + 1
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         KCNEXT = KC + K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC+K-1 ) = ONE / DBLE( AP( KC+K-1 ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL ZHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
+     $                     AP( KC ), 1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        DBLE( ZDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+K-1 ) )
+            AK = DBLE( AP( KC+K-1 ) ) / T
+            AKP1 = DBLE( AP( KCNEXT+K ) ) / T
+            AKKP1 = AP( KCNEXT+K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KC+K-1 ) = AKP1 / D
+            AP( KCNEXT+K ) = AK / D
+            AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL ZHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
+     $                     AP( KC ), 1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        DBLE( ZDOTC( K-1, WORK, 1, AP( KC ), 1 ) )
+               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+     $                            ZDOTC( K-1, AP( KC ), 1, AP( KCNEXT ),
+     $                            1 )
+               CALL ZCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+               CALL ZHPMV( UPLO, K-1, -CONE, AP, WORK, 1, ZERO,
+     $                     AP( KCNEXT ), 1 )
+               AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+     $                          DBLE( ZDOTC( K-1, WORK, 1, AP( KCNEXT ),
+     $                          1 ) )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT + K + 1
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            KPC = ( KP-1 )*KP / 2 + 1
+            CALL ZSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+            KX = KPC + KP - 1
+            DO 40 J = KP + 1, K - 1
+               KX = KX + J - 1
+               TEMP = DCONJG( AP( KC+J-1 ) )
+               AP( KC+J-1 ) = DCONJG( AP( KX ) )
+               AP( KX ) = TEMP
+   40       CONTINUE
+            AP( KC+KP-1 ) = DCONJG( AP( KC+KP-1 ) )
+            TEMP = AP( KC+K-1 )
+            AP( KC+K-1 ) = AP( KPC+KP-1 )
+            AP( KPC+KP-1 ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC+K+K-1 )
+               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+               AP( KC+K+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         KC = KCNEXT
+         GO TO 30
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         NPP = N*( N+1 ) / 2
+         K = N
+         KC = NPP
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         KCNEXT = KC - ( N-K+2 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC ) = ONE / DBLE( AP( KC ) )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL ZHPMV( UPLO, N-K, -CONE, AP( KC+N-K+1 ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - DBLE( ZDOTC( N-K, WORK, 1,
+     $                    AP( KC+1 ), 1 ) )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( AP( KCNEXT+1 ) )
+            AK = DBLE( AP( KCNEXT ) ) / T
+            AKP1 = DBLE( AP( KC ) ) / T
+            AKKP1 = AP( KCNEXT+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KCNEXT ) = AKP1 / D
+            AP( KC ) = AK / D
+            AP( KCNEXT+1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL ZHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ), WORK,
+     $                     1, ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - DBLE( ZDOTC( N-K, WORK, 1,
+     $                    AP( KC+1 ), 1 ) )
+               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+     $                          ZDOTC( N-K, AP( KC+1 ), 1,
+     $                          AP( KCNEXT+2 ), 1 )
+               CALL ZCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+               CALL ZHPMV( UPLO, N-K, -CONE, AP( KC+( N-K+1 ) ), WORK,
+     $                     1, ZERO, AP( KCNEXT+2 ), 1 )
+               AP( KCNEXT ) = AP( KCNEXT ) -
+     $                        DBLE( ZDOTC( N-K, WORK, 1, AP( KCNEXT+2 ),
+     $                        1 ) )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT - ( N-K+3 )
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+            IF( KP.LT.N )
+     $         CALL ZSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+            KX = KC + KP - K
+            DO 70 J = K + 1, KP - 1
+               KX = KX + N - J + 1
+               TEMP = DCONJG( AP( KC+J-K ) )
+               AP( KC+J-K ) = DCONJG( AP( KX ) )
+               AP( KX ) = TEMP
+   70       CONTINUE
+            AP( KC+KP-K ) = DCONJG( AP( KC+KP-K ) )
+            TEMP = AP( KC )
+            AP( KC ) = AP( KPC )
+            AP( KPC ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC-N+K-1 )
+               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+               AP( KC-N+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         KC = KCNEXT
+         GO TO 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHPTRI
+*
+      END
diff --git a/SRC/zhptrs.f b/SRC/zhptrs.f
new file mode 100644
index 00000000..70719393
--- /dev/null
+++ b/SRC/zhptrs.f
@@ -0,0 +1,401 @@
+      SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHPTRS solves a system of linear equations A*X = B with a complex
+*  Hermitian matrix A stored in packed format using the factorization
+*  A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.
+*
+*  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**H;
+*          = 'L':  Lower triangular, form is A = L*D*L**H.
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZHPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZHPTRF.
+*
+*  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            UPPER
+      INTEGER            J, K, KC, KP
+      DOUBLE PRECISION   S
+      COMPLEX*16         AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZGEMV, ZGERU, ZLACGV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHPTRS', -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
+         KC = N*( N+1 ) / 2 + 1
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         KC = KC - K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            S = DBLE( ONE ) / DBLE( AP( KC+K-1 ) )
+            CALL ZDSCAL( NRHS, S, 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 ZSWAP( 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 ZGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL ZGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+     $                  B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+K-2 )
+            AKM1 = AP( KC-1 ) / AKM1K
+            AK = AP( KC+K-1 ) / DCONJG( AKM1K )
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / DCONJG( AKM1K )
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            KC = KC - K + 1
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + K
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
+     $                     LDB, AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + 2*K + 1
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+     $                     LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            S = DBLE( ONE ) / DBLE( AP( KC ) )
+            CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB )
+            KC = KC + N - K + 1
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL ZSWAP( 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 ZGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+     $                     B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+1 )
+            AKM1 = AP( KC ) / DCONJG( AKM1K )
+            AK = AP( KC+N-K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / DCONJG( AKM1K )
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            KC = KC + 2*( N-K ) + 1
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         KC = KC - ( N-K+1 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N ) THEN
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZLACGV( NRHS, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
+     $                     B( K, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K, 1 ), LDB )
+*
+               CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+               CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
+     $                     B( K+1, 1 ), LDB, AP( KC-( N-K ) ), 1, ONE,
+     $                     B( K-1, 1 ), LDB )
+               CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC - ( N-K+2 )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZHPTRS
+*
+      END
diff --git a/SRC/zhsein.f b/SRC/zhsein.f
new file mode 100644
index 00000000..2cd0b80b
--- /dev/null
+++ b/SRC/zhsein.f
@@ -0,0 +1,350 @@
+      SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL,
+     $                   LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL,
+     $                   IFAILR, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EIGSRC, INITV, SIDE
+      INTEGER            INFO, LDH, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IFAILL( * ), IFAILR( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHSEIN uses inverse iteration to find specified right and/or left
+*  eigenvectors of a complex upper Hessenberg matrix H.
+*
+*  The right eigenvector x and the left eigenvector y of the matrix H
+*  corresponding to an eigenvalue w are defined by:
+*
+*               H * x = w * x,     y**h * H = w * y**h
+*
+*  where y**h denotes the conjugate transpose of the vector y.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R': compute right eigenvectors only;
+*          = 'L': compute left eigenvectors only;
+*          = 'B': compute both right and left eigenvectors.
+*
+*  EIGSRC  (input) CHARACTER*1
+*          Specifies the source of eigenvalues supplied in W:
+*          = 'Q': the eigenvalues were found using ZHSEQR; thus, if
+*                 H has zero subdiagonal elements, and so is
+*                 block-triangular, then the j-th eigenvalue can be
+*                 assumed to be an eigenvalue of the block containing
+*                 the j-th row/column.  This property allows ZHSEIN to
+*                 perform inverse iteration on just one diagonal block.
+*          = 'N': no assumptions are made on the correspondence
+*                 between eigenvalues and diagonal blocks.  In this
+*                 case, ZHSEIN must always perform inverse iteration
+*                 using the whole matrix H.
+*
+*  INITV   (input) CHARACTER*1
+*          = 'N': no initial vectors are supplied;
+*          = 'U': user-supplied initial vectors are stored in the arrays
+*                 VL and/or VR.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          Specifies the eigenvectors to be computed. To select the
+*          eigenvector corresponding to the eigenvalue W(j),
+*          SELECT(j) must be set to .TRUE..
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) COMPLEX*16 array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  W       (input/output) COMPLEX*16 array, dimension (N)
+*          On entry, the eigenvalues of H.
+*          On exit, the real parts of W may have been altered since
+*          close eigenvalues are perturbed slightly in searching for
+*          independent eigenvectors.
+*
+*  VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)
+*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
+*          contain starting vectors for the inverse iteration for the
+*          left eigenvectors; the starting vector for each eigenvector
+*          must be in the same column in which the eigenvector will be
+*          stored.
+*          On exit, if SIDE = 'L' or 'B', the left eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VL, in the same order as their eigenvalues.
+*          If SIDE = 'R', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
+*
+*  VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)
+*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
+*          contain starting vectors for the inverse iteration for the
+*          right eigenvectors; the starting vector for each eigenvector
+*          must be in the same column in which the eigenvector will be
+*          stored.
+*          On exit, if SIDE = 'R' or 'B', the right eigenvectors
+*          specified by SELECT will be stored consecutively in the
+*          columns of VR, in the same order as their eigenvalues.
+*          If SIDE = 'L', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
+*
+*  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 required to
+*          store the eigenvectors (= the number of .TRUE. elements in
+*          SELECT).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N*N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  IFAILL  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
+*          eigenvector in the i-th column of VL (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
+*          eigenvector converged satisfactorily.
+*          If SIDE = 'R', IFAILL is not referenced.
+*
+*  IFAILR  (output) INTEGER array, dimension (MM)
+*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
+*          eigenvector in the i-th column of VR (corresponding to the
+*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
+*          eigenvector converged satisfactorily.
+*          If SIDE = 'L', IFAILR is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, i is the number of eigenvectors which
+*                failed to converge; see IFAILL and IFAILR for further
+*                details.
+*
+*  Further Details
+*  ===============
+*
+*  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 ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   RZERO
+      PARAMETER          ( RZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            BOTHV, FROMQR, LEFTV, NOINIT, RIGHTV
+      INTEGER            I, IINFO, K, KL, KLN, KR, KS, LDWORK
+      DOUBLE PRECISION   EPS3, HNORM, SMLNUM, ULP, UNFL
+      COMPLEX*16         CDUM, WK
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHS
+      EXTERNAL           LSAME, DLAMCH, ZLANHS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLAEIN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, 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
+*
+      FROMQR = LSAME( EIGSRC, 'Q' )
+*
+      NOINIT = LSAME( INITV, 'N' )
+*
+*     Set M to the number of columns required to store the selected
+*     eigenvectors.
+*
+      M = 0
+      DO 10 K = 1, N
+         IF( SELECT( K ) )
+     $      M = M + 1
+   10 CONTINUE
+*
+      INFO = 0
+      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -1
+      ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+         INFO = -12
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHSEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set machine-dependent constants.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( N / ULP )
+*
+      LDWORK = N
+*
+      KL = 1
+      KLN = 0
+      IF( FROMQR ) THEN
+         KR = 0
+      ELSE
+         KR = N
+      END IF
+      KS = 1
+*
+      DO 100 K = 1, N
+         IF( SELECT( K ) ) THEN
+*
+*           Compute eigenvector(s) corresponding to W(K).
+*
+            IF( FROMQR ) THEN
+*
+*              If affiliation of eigenvalues is known, check whether
+*              the matrix splits.
+*
+*              Determine KL and KR such that 1 <= KL <= K <= KR <= N
+*              and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
+*              KR = N).
+*
+*              Then inverse iteration can be performed with the
+*              submatrix H(KL:N,KL:N) for a left eigenvector, and with
+*              the submatrix H(1:KR,1:KR) for a right eigenvector.
+*
+               DO 20 I = K, KL + 1, -1
+                  IF( H( I, I-1 ).EQ.ZERO )
+     $               GO TO 30
+   20          CONTINUE
+   30          CONTINUE
+               KL = I
+               IF( K.GT.KR ) THEN
+                  DO 40 I = K, N - 1
+                     IF( H( I+1, I ).EQ.ZERO )
+     $                  GO TO 50
+   40             CONTINUE
+   50             CONTINUE
+                  KR = I
+               END IF
+            END IF
+*
+            IF( KL.NE.KLN ) THEN
+               KLN = KL
+*
+*              Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
+*              has not ben computed before.
+*
+               HNORM = ZLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, RWORK )
+               IF( HNORM.GT.RZERO ) THEN
+                  EPS3 = HNORM*ULP
+               ELSE
+                  EPS3 = SMLNUM
+               END IF
+            END IF
+*
+*           Perturb eigenvalue if it is close to any previous
+*           selected eigenvalues affiliated to the submatrix
+*           H(KL:KR,KL:KR). Close roots are modified by EPS3.
+*
+            WK = W( K )
+   60       CONTINUE
+            DO 70 I = K - 1, KL, -1
+               IF( SELECT( I ) .AND. CABS1( W( I )-WK ).LT.EPS3 ) THEN
+                  WK = WK + EPS3
+                  GO TO 60
+               END IF
+   70       CONTINUE
+            W( K ) = WK
+*
+            IF( LEFTV ) THEN
+*
+*              Compute left eigenvector.
+*
+               CALL ZLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
+     $                      WK, VL( KL, KS ), WORK, LDWORK, RWORK, EPS3,
+     $                      SMLNUM, IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  INFO = INFO + 1
+                  IFAILL( KS ) = K
+               ELSE
+                  IFAILL( KS ) = 0
+               END IF
+               DO 80 I = 1, KL - 1
+                  VL( I, KS ) = ZERO
+   80          CONTINUE
+            END IF
+            IF( RIGHTV ) THEN
+*
+*              Compute right eigenvector.
+*
+               CALL ZLAEIN( .TRUE., NOINIT, KR, H, LDH, WK, VR( 1, KS ),
+     $                      WORK, LDWORK, RWORK, EPS3, SMLNUM, IINFO )
+               IF( IINFO.GT.0 ) THEN
+                  INFO = INFO + 1
+                  IFAILR( KS ) = K
+               ELSE
+                  IFAILR( KS ) = 0
+               END IF
+               DO 90 I = KR + 1, N
+                  VR( I, KS ) = ZERO
+   90          CONTINUE
+            END IF
+            KS = KS + 1
+         END IF
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of ZHSEIN
+*
+      END
diff --git a/SRC/zhseqr.f b/SRC/zhseqr.f
new file mode 100644
index 00000000..fb721dad
--- /dev/null
+++ b/SRC/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/zlabrd.f b/SRC/zlabrd.f
new file mode 100644
index 00000000..fb482c84
--- /dev/null
+++ b/SRC/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/zlacgv.f b/SRC/zlacgv.f
new file mode 100644
index 00000000..0033e306
--- /dev/null
+++ b/SRC/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/zlacn2.f b/SRC/zlacn2.f
new file mode 100644
index 00000000..99f7ae35
--- /dev/null
+++ b/SRC/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/zlacon.f b/SRC/zlacon.f
new file mode 100644
index 00000000..5773ef92
--- /dev/null
+++ b/SRC/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/zlacp2.f b/SRC/zlacp2.f
new file mode 100644
index 00000000..b42c30b3
--- /dev/null
+++ b/SRC/zlacp2.f
@@ -0,0 +1,91 @@
+      SUBROUTINE ZLACP2( 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, * )
+      COMPLEX*16         B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACP2 copies all or part of a real two-dimensional matrix A to a
+*  complex 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 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 ZLACP2
+*
+      END
diff --git a/SRC/zlacpy.f b/SRC/zlacpy.f
new file mode 100644
index 00000000..8878311a
--- /dev/null
+++ b/SRC/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/zlacrm.f b/SRC/zlacrm.f
new file mode 100644
index 00000000..b3f5a35d
--- /dev/null
+++ b/SRC/zlacrm.f
@@ -0,0 +1,110 @@
+      SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDB, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACRM performs a very simple matrix-matrix multiplication:
+*           C := A * B,
+*  where A is M by N and complex; B is N by N and real;
+*  C is M by N and complex.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A and of the matrix C.
+*          M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns and rows of the matrix B and
+*          the number of columns of the matrix C.
+*          N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA, N)
+*          A contains the M by N matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >=max(1,M).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
+*          B contains the N by N matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >=max(1,N).
+*
+*  C       (input) COMPLEX*16 array, dimension (LDC, N)
+*          C contains the M by N matrix C.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >=max(1,N).
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*M*N)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DIMAG
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+     $   RETURN
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, M
+            RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) )
+   10    CONTINUE
+   20 CONTINUE
+*
+      L = M*N + 1
+      CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
+     $            RWORK( L ), M )
+      DO 40 J = 1, N
+         DO 30 I = 1, M
+            C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
+   30    CONTINUE
+   40 CONTINUE
+*
+      DO 60 J = 1, N
+         DO 50 I = 1, M
+            RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) )
+   50    CONTINUE
+   60 CONTINUE
+      CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO,
+     $            RWORK( L ), M )
+      DO 80 J = 1, N
+         DO 70 I = 1, M
+            C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
+     $                  RWORK( L+( J-1 )*M+I-1 ) )
+   70    CONTINUE
+   80 CONTINUE
+*
+      RETURN
+*
+*     End of ZLACRM
+*
+      END
diff --git a/SRC/zlacrt.f b/SRC/zlacrt.f
new file mode 100644
index 00000000..7a0862cb
--- /dev/null
+++ b/SRC/zlacrt.f
@@ -0,0 +1,90 @@
+      SUBROUTINE ZLACRT( 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
+      COMPLEX*16         C, S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         CX( * ), CY( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACRT performs the operation
+*
+*     (  c  s )( x )  ==> ( x )
+*     ( -s  c )( y )      ( y )
+*
+*  where c and s are complex and the vectors x and y 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 CX.  INCX <> 0.
+*
+*  CY      (input/output) COMPLEX*16 array, dimension (N)
+*          On input, the vector y.
+*          On output, CY is overwritten with -s*x + c*y.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive values of CY.  INCY <> 0.
+*
+*  C       (input) COMPLEX*16
+*  S       (input) COMPLEX*16
+*          C and S define the matrix
+*             [  C   S  ].
+*             [ -S   C  ]
+*
+* =====================================================================
+*
+*     .. 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/zladiv.f b/SRC/zladiv.f
new file mode 100644
index 00000000..4a12055e
--- /dev/null
+++ b/SRC/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/zlaed0.f b/SRC/zlaed0.f
new file mode 100644
index 00000000..92ad1f4c
--- /dev/null
+++ b/SRC/zlaed0.f
@@ -0,0 +1,288 @@
+      SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDQ, LDQS, N, QSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
+      COMPLEX*16         Q( LDQ, * ), QSTORE( LDQS, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Using the divide and conquer method, ZLAED0 computes all eigenvalues
+*  of a symmetric tridiagonal matrix which is one diagonal block of
+*  those from reducing a dense or band Hermitian matrix and
+*  corresponding eigenvectors of the dense or band matrix.
+*
+*  Arguments
+*  =========
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the unitary matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, the diagonal elements of the tridiagonal matrix.
+*         On exit, the eigenvalues in ascending order.
+*
+*  E      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*         On entry, the off-diagonal elements of the tridiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  Q      (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*         On entry, Q must contain an QSIZ x N matrix whose columns
+*         unitarily orthonormal. It is a part of the unitary matrix
+*         that reduces the full dense Hermitian matrix to a
+*         (reducible) symmetric tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  IWORK  (workspace) INTEGER array,
+*         the dimension of IWORK must be at least
+*                      6 + 6*N + 5*N*lg N
+*                      ( lg( N ) = smallest integer k
+*                                  such that 2^k >= N )
+*
+*  RWORK  (workspace) DOUBLE PRECISION array,
+*                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)
+*                        ( lg( N ) = smallest integer k
+*                                    such that 2^k >= N )
+*
+*  QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N)
+*         Used to store parts of
+*         the eigenvector matrix when the updating matrix multiplies
+*         take place.
+*
+*  LDQS   (input) INTEGER
+*         The leading dimension of the array QSTORE.
+*         LDQS >= max(1,N).
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  The algorithm failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  =====================================================================
+*
+*  Warning:      N could be as big as QSIZ!
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
+     $                   IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
+     $                   J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1,
+     $                   SPM1, SPM2, SUBMAT, SUBPBS, TLVLS
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+*     IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN
+*        INFO = -1
+*     ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) )
+*    $        THEN
+      IF( QSIZ.LT.MAX( 0, N ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLAED0', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 )
+*
+*     Determine the size and placement of the submatrices, and save in
+*     the leading elements of IWORK.
+*
+      IWORK( 1 ) = N
+      SUBPBS = 1
+      TLVLS = 0
+   10 CONTINUE
+      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
+         DO 20 J = SUBPBS, 1, -1
+            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
+            IWORK( 2*J-1 ) = IWORK( J ) / 2
+   20    CONTINUE
+         TLVLS = TLVLS + 1
+         SUBPBS = 2*SUBPBS
+         GO TO 10
+      END IF
+      DO 30 J = 2, SUBPBS
+         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
+   30 CONTINUE
+*
+*     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
+*     using rank-1 modifications (cuts).
+*
+      SPM1 = SUBPBS - 1
+      DO 40 I = 1, SPM1
+         SUBMAT = IWORK( I ) + 1
+         SMM1 = SUBMAT - 1
+         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
+         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
+   40 CONTINUE
+*
+      INDXQ = 4*N + 3
+*
+*     Set up workspaces for eigenvalues only/accumulate new vectors
+*     routine
+*
+      TEMP = LOG( DBLE( N ) ) / LOG( TWO )
+      LGN = INT( TEMP )
+      IF( 2**LGN.LT.N )
+     $   LGN = LGN + 1
+      IF( 2**LGN.LT.N )
+     $   LGN = LGN + 1
+      IPRMPT = INDXQ + N + 1
+      IPERM = IPRMPT + N*LGN
+      IQPTR = IPERM + N*LGN
+      IGIVPT = IQPTR + N + 2
+      IGIVCL = IGIVPT + N*LGN
+*
+      IGIVNM = 1
+      IQ = IGIVNM + 2*N*LGN
+      IWREM = IQ + N**2 + 1
+*     Initialize pointers
+      DO 50 I = 0, SUBPBS
+         IWORK( IPRMPT+I ) = 1
+         IWORK( IGIVPT+I ) = 1
+   50 CONTINUE
+      IWORK( IQPTR ) = 1
+*
+*     Solve each submatrix eigenproblem at the bottom of the divide and
+*     conquer tree.
+*
+      CURR = 0
+      DO 70 I = 0, SPM1
+         IF( I.EQ.0 ) THEN
+            SUBMAT = 1
+            MATSIZ = IWORK( 1 )
+         ELSE
+            SUBMAT = IWORK( I ) + 1
+            MATSIZ = IWORK( I+1 ) - IWORK( I )
+         END IF
+         LL = IQ - 1 + IWORK( IQPTR+CURR )
+         CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+     $                RWORK( LL ), MATSIZ, RWORK, INFO )
+         CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ),
+     $                MATSIZ, QSTORE( 1, SUBMAT ), LDQS,
+     $                RWORK( IWREM ) )
+         IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
+         CURR = CURR + 1
+         IF( INFO.GT.0 ) THEN
+            INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+            RETURN
+         END IF
+         K = 1
+         DO 60 J = SUBMAT, IWORK( I+1 )
+            IWORK( INDXQ+J ) = K
+            K = K + 1
+   60    CONTINUE
+   70 CONTINUE
+*
+*     Successively merge eigensystems of adjacent submatrices
+*     into eigensystem for the corresponding larger matrix.
+*
+*     while ( SUBPBS > 1 )
+*
+      CURLVL = 1
+   80 CONTINUE
+      IF( SUBPBS.GT.1 ) THEN
+         SPM2 = SUBPBS - 2
+         DO 90 I = 0, SPM2, 2
+            IF( I.EQ.0 ) THEN
+               SUBMAT = 1
+               MATSIZ = IWORK( 2 )
+               MSD2 = IWORK( 1 )
+               CURPRB = 0
+            ELSE
+               SUBMAT = IWORK( I ) + 1
+               MATSIZ = IWORK( I+2 ) - IWORK( I )
+               MSD2 = MATSIZ / 2
+               CURPRB = CURPRB + 1
+            END IF
+*
+*     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
+*     into an eigensystem of size MATSIZ.  ZLAED7 handles the case
+*     when the eigenvectors of a full or band Hermitian matrix (which
+*     was reduced to tridiagonal form) are desired.
+*
+*     I am free to use Q as a valuable working space until Loop 150.
+*
+            CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB,
+     $                   D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
+     $                   E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ),
+     $                   RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ),
+     $                   IWORK( IPERM ), IWORK( IGIVPT ),
+     $                   IWORK( IGIVCL ), RWORK( IGIVNM ),
+     $                   Q( 1, SUBMAT ), RWORK( IWREM ),
+     $                   IWORK( SUBPBS+1 ), INFO )
+            IF( INFO.GT.0 ) THEN
+               INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+               RETURN
+            END IF
+            IWORK( I / 2+1 ) = IWORK( I+2 )
+   90    CONTINUE
+         SUBPBS = SUBPBS / 2
+         CURLVL = CURLVL + 1
+         GO TO 80
+      END IF
+*
+*     end while
+*
+*     Re-merge the eigenvalues/vectors which were deflated at the final
+*     merge step.
+*
+      DO 100 I = 1, N
+         J = IWORK( INDXQ+I )
+         RWORK( I ) = D( J )
+         CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
+  100 CONTINUE
+      CALL DCOPY( N, RWORK, 1, D, 1 )
+*
+      RETURN
+*
+*     End of ZLAED0
+*
+      END
diff --git a/SRC/zlaed7.f b/SRC/zlaed7.f
new file mode 100644
index 00000000..afe93bb6
--- /dev/null
+++ b/SRC/zlaed7.f
@@ -0,0 +1,264 @@
+      SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
+     $                   LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM,
+     $                   GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ,
+     $                   TLVLS
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
+     $                   IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
+      DOUBLE PRECISION   D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * )
+      COMPLEX*16         Q( LDQ, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAED7 computes the updated eigensystem of a diagonal
+*  matrix after modification by a rank-one symmetric matrix. This
+*  routine is used only for the eigenproblem which requires all
+*  eigenvalues and optionally eigenvectors of a dense or banded
+*  Hermitian matrix that has been reduced to tridiagonal form.
+*
+*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+*    where Z = Q'u, u is a vector of length N with ones in the
+*    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+*     The eigenvectors of the original matrix are stored in Q, and the
+*     eigenvalues are in D.  The algorithm consists of three stages:
+*
+*        The first stage consists of deflating the size of the problem
+*        when there are multiple eigenvalues or if there is a zero in
+*        the Z vector.  For each such occurence the dimension of the
+*        secular equation problem is reduced by one.  This stage is
+*        performed by the routine DLAED2.
+*
+*        The second stage consists of calculating the updated
+*        eigenvalues. This is done by finding the roots of the secular
+*        equation via the routine DLAED4 (as called by SLAED3).
+*        This routine also calculates the eigenvectors of the current
+*        problem.
+*
+*        The final stage consists of computing the updated eigenvectors
+*        directly using the updated eigenvalues.  The eigenvectors for
+*        the current problem are multiplied with the eigenvectors from
+*        the overall problem.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  CUTPNT (input) INTEGER
+*         Contains the location of the last eigenvalue in the leading
+*         sub-matrix.  min(1,N) <= CUTPNT <= N.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the unitary matrix used to reduce
+*         the full matrix to tridiagonal form.  QSIZ >= N.
+*
+*  TLVLS  (input) INTEGER
+*         The total number of merging levels in the overall divide and
+*         conquer tree.
+*
+*  CURLVL (input) INTEGER
+*         The current level in the overall merge routine,
+*         0 <= curlvl <= tlvls.
+*
+*  CURPBM (input) INTEGER
+*         The current problem in the current level in the overall
+*         merge routine (counting from upper left to lower right).
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, the eigenvalues of the rank-1-perturbed matrix.
+*         On exit, the eigenvalues of the repaired matrix.
+*
+*  Q      (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*         On entry, the eigenvectors of the rank-1-perturbed matrix.
+*         On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  RHO    (input) DOUBLE PRECISION
+*         Contains the subdiagonal element used to create the rank-1
+*         modification.
+*
+*  INDXQ  (output) INTEGER array, dimension (N)
+*         This contains the permutation which will reintegrate the
+*         subproblem just solved back into sorted order,
+*         ie. D( INDXQ( I = 1, N ) ) will be in ascending order.
+*
+*  IWORK  (workspace) INTEGER array, dimension (4*N)
+*
+*  RWORK  (workspace) DOUBLE PRECISION array,
+*                                 dimension (3*N+2*QSIZ*N)
+*
+*  WORK   (workspace) COMPLEX*16 array, dimension (QSIZ*N)
+*
+*  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
+*         Stores eigenvectors of submatrices encountered during
+*         divide and conquer, packed together. QPTR points to
+*         beginning of the submatrices.
+*
+*  QPTR   (input/output) INTEGER array, dimension (N+2)
+*         List of indices pointing to beginning of submatrices stored
+*         in QSTORE. The submatrices are numbered starting at the
+*         bottom left of the divide and conquer tree, from left to
+*         right and bottom to top.
+*
+*  PRMPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in PERM a
+*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
+*         indicates the size of the permutation and also the size of
+*         the full, non-deflated problem.
+*
+*  PERM   (input) INTEGER array, dimension (N lg N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (input) INTEGER array, dimension (N lg N)
+*         Contains a list of pointers which indicate where in GIVCOL a
+*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
+*         indicates the number of Givens rotations.
+*
+*  GIVCOL (input) INTEGER array, dimension (2, N lg N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = 1, an eigenvalue did not converge
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            COLTYP, CURR, I, IDLMDA, INDX,
+     $                   INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+*     IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+*        INFO = -1
+*     ELSE IF( N.LT.0 ) THEN
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
+         INFO = -2
+      ELSE IF( QSIZ.LT.N ) THEN
+         INFO = -3
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLAED7', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     The following values are for bookkeeping purposes only.  They are
+*     integer pointers which indicate the portion of the workspace
+*     used by a particular array in DLAED2 and SLAED3.
+*
+      IZ = 1
+      IDLMDA = IZ + N
+      IW = IDLMDA + N
+      IQ = IW + N
+*
+      INDX = 1
+      INDXC = INDX + N
+      COLTYP = INDXC + N
+      INDXP = COLTYP + N
+*
+*     Form the z-vector which consists of the last row of Q_1 and the
+*     first row of Q_2.
+*
+      PTR = 1 + 2**TLVLS
+      DO 10 I = 1, CURLVL - 1
+         PTR = PTR + 2**( TLVLS-I )
+   10 CONTINUE
+      CURR = PTR + CURPBM
+      CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+     $             GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ),
+     $             RWORK( IZ+N ), INFO )
+*
+*     When solving the final problem, we no longer need the stored data,
+*     so we will overwrite the data from this level onto the previously
+*     used storage space.
+*
+      IF( CURLVL.EQ.TLVLS ) THEN
+         QPTR( CURR ) = 1
+         PRMPTR( CURR ) = 1
+         GIVPTR( CURR ) = 1
+      END IF
+*
+*     Sort and Deflate eigenvalues.
+*
+      CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ),
+     $             RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ),
+     $             IWORK( INDXP ), IWORK( INDX ), INDXQ,
+     $             PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
+     $             GIVCOL( 1, GIVPTR( CURR ) ),
+     $             GIVNUM( 1, GIVPTR( CURR ) ), INFO )
+      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
+      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
+*
+*     Solve Secular Equation.
+*
+      IF( K.NE.0 ) THEN
+         CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO,
+     $                RWORK( IDLMDA ), RWORK( IW ),
+     $                QSTORE( QPTR( CURR ) ), K, INFO )
+         CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q,
+     $                LDQ, RWORK( IQ ) )
+         QPTR( CURR+1 ) = QPTR( CURR ) + K**2
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+*
+*     Prepare the INDXQ sorting premutation.
+*
+         N1 = K
+         N2 = N - K
+         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
+      ELSE
+         QPTR( CURR+1 ) = QPTR( CURR )
+         DO 20 I = 1, N
+            INDXQ( I ) = I
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLAED7
+*
+      END
diff --git a/SRC/zlaed8.f b/SRC/zlaed8.f
new file mode 100644
index 00000000..3d592d29
--- /dev/null
+++ b/SRC/zlaed8.f
@@ -0,0 +1,363 @@
+      SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA,
+     $                   Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR,
+     $                   GIVCOL, GIVNUM, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ
+      DOUBLE PRECISION   RHO
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ),
+     $                   INDXQ( * ), PERM( * )
+      DOUBLE PRECISION   D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ),
+     $                   Z( * )
+      COMPLEX*16         Q( LDQ, * ), Q2( LDQ2, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAED8 merges the two sets of eigenvalues together into a single
+*  sorted set.  Then it tries to deflate the size of the problem.
+*  There are two ways in which deflation can occur:  when two or more
+*  eigenvalues are close together or if there is a tiny element in the
+*  Z vector.  For each such occurrence the order of the related secular
+*  equation problem is reduced by one.
+*
+*  Arguments
+*  =========
+*
+*  K      (output) INTEGER
+*         Contains the number of non-deflated eigenvalues.
+*         This is the order of the related secular equation.
+*
+*  N      (input) INTEGER
+*         The dimension of the symmetric tridiagonal matrix.  N >= 0.
+*
+*  QSIZ   (input) INTEGER
+*         The dimension of the unitary matrix used to reduce
+*         the dense or band matrix to tridiagonal form.
+*         QSIZ >= N if ICOMPQ = 1.
+*
+*  Q      (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*         On entry, Q contains the eigenvectors of the partially solved
+*         system which has been previously updated in matrix
+*         multiplies with other partially solved eigensystems.
+*         On exit, Q contains the trailing (N-K) updated eigenvectors
+*         (those which were deflated) in its last N-K columns.
+*
+*  LDQ    (input) INTEGER
+*         The leading dimension of the array Q.  LDQ >= max( 1, N ).
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry, D contains the eigenvalues of the two submatrices to
+*         be combined.  On exit, D contains the trailing (N-K) updated
+*         eigenvalues (those which were deflated) sorted into increasing
+*         order.
+*
+*  RHO    (input/output) DOUBLE PRECISION
+*         Contains the off diagonal element associated with the rank-1
+*         cut which originally split the two submatrices which are now
+*         being recombined. RHO is modified during the computation to
+*         the value required by DLAED3.
+*
+*  CUTPNT (input) INTEGER
+*         Contains the location of the last eigenvalue in the leading
+*         sub-matrix.  MIN(1,N) <= CUTPNT <= N.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension (N)
+*         On input this vector contains the updating vector (the last
+*         row of the first sub-eigenvector matrix and the first row of
+*         the second sub-eigenvector matrix).  The contents of Z are
+*         destroyed during the updating process.
+*
+*  DLAMDA (output) DOUBLE PRECISION array, dimension (N)
+*         Contains a copy of the first K eigenvalues which will be used
+*         by DLAED3 to form the secular equation.
+*
+*  Q2     (output) COMPLEX*16 array, dimension (LDQ2,N)
+*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
+*         Contains a copy of the first K eigenvectors which will be used
+*         by DLAED7 in a matrix multiply (DGEMM) to update the new
+*         eigenvectors.
+*
+*  LDQ2   (input) INTEGER
+*         The leading dimension of the array Q2.  LDQ2 >= max( 1, N ).
+*
+*  W      (output) DOUBLE PRECISION array, dimension (N)
+*         This will hold the first k values of the final
+*         deflation-altered z-vector and will be passed to DLAED3.
+*
+*  INDXP  (workspace) INTEGER array, dimension (N)
+*         This will contain the permutation used to place deflated
+*         values of D at the end of the array. On output INDXP(1:K)
+*         points to the nondeflated D-values and INDXP(K+1:N)
+*         points to the deflated eigenvalues.
+*
+*  INDX   (workspace) INTEGER array, dimension (N)
+*         This will contain the permutation used to sort the contents of
+*         D into ascending order.
+*
+*  INDXQ  (input) INTEGER array, dimension (N)
+*         This contains the permutation which separately sorts the two
+*         sub-problems in D into ascending order.  Note that elements in
+*         the second half of this permutation must first have CUTPNT
+*         added to their values in order to be accurate.
+*
+*  PERM   (output) INTEGER array, dimension (N)
+*         Contains the permutations (from deflation and sorting) to be
+*         applied to each eigenblock.
+*
+*  GIVPTR (output) INTEGER
+*         Contains the number of Givens rotations which took place in
+*         this subproblem.
+*
+*  GIVCOL (output) INTEGER array, dimension (2, N)
+*         Each pair of numbers indicates a pair of columns to take place
+*         in a Givens rotation.
+*
+*  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
+*         Each number indicates the S value to be used in the
+*         corresponding Givens rotation.
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT
+      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
+     $                   TWO = 2.0D0, EIGHT = 8.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
+      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           IDAMAX, DLAMCH, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT,
+     $                   ZLACPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( QSIZ.LT.N ) THEN
+         INFO = -3
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
+         INFO = -8
+      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLAED8', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      N1 = CUTPNT
+      N2 = N - N1
+      N1P1 = N1 + 1
+*
+      IF( RHO.LT.ZERO ) THEN
+         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
+      END IF
+*
+*     Normalize z so that norm(z) = 1
+*
+      T = ONE / SQRT( TWO )
+      DO 10 J = 1, N
+         INDX( J ) = J
+   10 CONTINUE
+      CALL DSCAL( N, T, Z, 1 )
+      RHO = ABS( TWO*RHO )
+*
+*     Sort the eigenvalues into increasing order
+*
+      DO 20 I = CUTPNT + 1, N
+         INDXQ( I ) = INDXQ( I ) + CUTPNT
+   20 CONTINUE
+      DO 30 I = 1, N
+         DLAMDA( I ) = D( INDXQ( I ) )
+         W( I ) = Z( INDXQ( I ) )
+   30 CONTINUE
+      I = 1
+      J = CUTPNT + 1
+      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
+      DO 40 I = 1, N
+         D( I ) = DLAMDA( INDX( I ) )
+         Z( I ) = W( INDX( I ) )
+   40 CONTINUE
+*
+*     Calculate the allowable deflation tolerance
+*
+      IMAX = IDAMAX( N, Z, 1 )
+      JMAX = IDAMAX( N, D, 1 )
+      EPS = DLAMCH( 'Epsilon' )
+      TOL = EIGHT*EPS*ABS( D( JMAX ) )
+*
+*     If the rank-1 modifier is small enough, no more needs to be done
+*     -- except to reorganize Q so that its columns correspond with the
+*     elements in D.
+*
+      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+         K = 0
+         DO 50 J = 1, N
+            PERM( J ) = INDXQ( INDX( J ) )
+            CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+   50    CONTINUE
+         CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ )
+         RETURN
+      END IF
+*
+*     If there are multiple eigenvalues then the problem deflates.  Here
+*     the number of equal eigenvalues are found.  As each equal
+*     eigenvalue is found, an elementary reflector is computed to rotate
+*     the corresponding eigensubspace so that the corresponding
+*     components of Z are zero in this new basis.
+*
+      K = 0
+      GIVPTR = 0
+      K2 = N + 1
+      DO 60 J = 1, N
+         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*           Deflate due to small z component.
+*
+            K2 = K2 - 1
+            INDXP( K2 ) = J
+            IF( J.EQ.N )
+     $         GO TO 100
+         ELSE
+            JLAM = J
+            GO TO 70
+         END IF
+   60 CONTINUE
+   70 CONTINUE
+      J = J + 1
+      IF( J.GT.N )
+     $   GO TO 90
+      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+*        Deflate due to small z component.
+*
+         K2 = K2 - 1
+         INDXP( K2 ) = J
+      ELSE
+*
+*        Check if eigenvalues are close enough to allow deflation.
+*
+         S = Z( JLAM )
+         C = Z( J )
+*
+*        Find sqrt(a**2+b**2) without overflow or
+*        destructive underflow.
+*
+         TAU = DLAPY2( C, S )
+         T = D( J ) - D( JLAM )
+         C = C / TAU
+         S = -S / TAU
+         IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+*           Deflation is possible.
+*
+            Z( J ) = TAU
+            Z( JLAM ) = ZERO
+*
+*           Record the appropriate Givens rotation
+*
+            GIVPTR = GIVPTR + 1
+            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
+            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
+            GIVNUM( 1, GIVPTR ) = C
+            GIVNUM( 2, GIVPTR ) = S
+            CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
+     $                  Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
+            T = D( JLAM )*C*C + D( J )*S*S
+            D( J ) = D( JLAM )*S*S + D( J )*C*C
+            D( JLAM ) = T
+            K2 = K2 - 1
+            I = 1
+   80       CONTINUE
+            IF( K2+I.LE.N ) THEN
+               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
+                  INDXP( K2+I-1 ) = INDXP( K2+I )
+                  INDXP( K2+I ) = JLAM
+                  I = I + 1
+                  GO TO 80
+               ELSE
+                  INDXP( K2+I-1 ) = JLAM
+               END IF
+            ELSE
+               INDXP( K2+I-1 ) = JLAM
+            END IF
+            JLAM = J
+         ELSE
+            K = K + 1
+            W( K ) = Z( JLAM )
+            DLAMDA( K ) = D( JLAM )
+            INDXP( K ) = JLAM
+            JLAM = J
+         END IF
+      END IF
+      GO TO 70
+   90 CONTINUE
+*
+*     Record the last eigenvalue.
+*
+      K = K + 1
+      W( K ) = Z( JLAM )
+      DLAMDA( K ) = D( JLAM )
+      INDXP( K ) = JLAM
+*
+  100 CONTINUE
+*
+*     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+*     and Q2 respectively.  The eigenvalues/vectors which were not
+*     deflated go into the first K slots of DLAMDA and Q2 respectively,
+*     while those which were deflated go into the last N - K slots.
+*
+      DO 110 J = 1, N
+         JP = INDXP( J )
+         DLAMDA( J ) = D( JP )
+         PERM( J ) = INDXQ( INDX( JP ) )
+         CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+  110 CONTINUE
+*
+*     The deflated eigenvalues and their corresponding vectors go back
+*     into the last N - K slots of D and Q respectively.
+*
+      IF( K.LT.N ) THEN
+         CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+         CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ),
+     $                LDQ )
+      END IF
+*
+      RETURN
+*
+*     End of ZLAED8
+*
+      END
diff --git a/SRC/zlaein.f b/SRC/zlaein.f
new file mode 100644
index 00000000..eca2d8f9
--- /dev/null
+++ b/SRC/zlaein.f
@@ -0,0 +1,263 @@
+      SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK,
+     $                   EPS3, SMLNUM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            NOINIT, RIGHTV
+      INTEGER            INFO, LDB, LDH, N
+      DOUBLE PRECISION   EPS3, SMLNUM
+      COMPLEX*16         W
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         B( LDB, * ), H( LDH, * ), V( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAEIN uses inverse iteration to find a right or left eigenvector
+*  corresponding to the eigenvalue W of a complex upper Hessenberg
+*  matrix H.
+*
+*  Arguments
+*  =========
+*
+*  RIGHTV   (input) LOGICAL
+*          = .TRUE. : compute right eigenvector;
+*          = .FALSE.: compute left eigenvector.
+*
+*  NOINIT   (input) LOGICAL
+*          = .TRUE. : no initial vector supplied in V
+*          = .FALSE.: initial vector supplied in V.
+*
+*  N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*  H       (input) COMPLEX*16 array, dimension (LDH,N)
+*          The upper Hessenberg matrix H.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max(1,N).
+*
+*  W       (input) COMPLEX*16
+*          The eigenvalue of H whose corresponding right or left
+*          eigenvector is to be computed.
+*
+*  V       (input/output) COMPLEX*16 array, dimension (N)
+*          On entry, if NOINIT = .FALSE., V must contain a starting
+*          vector for inverse iteration; otherwise V need not be set.
+*          On exit, V contains the computed eigenvector, normalized so
+*          that the component of largest magnitude has magnitude 1; here
+*          the magnitude of a complex number (x,y) is taken to be
+*          |x| + |y|.
+*
+*  B       (workspace) COMPLEX*16 array, dimension (LDB,N)
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  EPS3    (input) DOUBLE PRECISION
+*          A small machine-dependent value which is used to perturb
+*          close eigenvalues, and to replace zero pivots.
+*
+*  SMLNUM  (input) DOUBLE PRECISION
+*          A machine-dependent value close to the underflow threshold.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          = 1:  inverse iteration did not converge; V is set to the
+*                last iterate.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, TENTH
+      PARAMETER          ( ONE = 1.0D+0, TENTH = 1.0D-1 )
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          NORMIN, TRANS
+      INTEGER            I, IERR, ITS, J
+      DOUBLE PRECISION   GROWTO, NRMSML, ROOTN, RTEMP, SCALE, VNORM
+      COMPLEX*16         CDUM, EI, EJ, TEMP, X
+*     ..
+*     .. External Functions ..
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DZASUM, DZNRM2
+      COMPLEX*16         ZLADIV
+      EXTERNAL           IZAMAX, DZASUM, DZNRM2, ZLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZDSCAL, ZLATRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     GROWTO is the threshold used in the acceptance test for an
+*     eigenvector.
+*
+      ROOTN = SQRT( DBLE( N ) )
+      GROWTO = TENTH / ROOTN
+      NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
+*
+*     Form B = H - W*I (except that the subdiagonal elements are not
+*     stored).
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, J - 1
+            B( I, J ) = H( I, J )
+   10    CONTINUE
+         B( J, J ) = H( J, J ) - W
+   20 CONTINUE
+*
+      IF( NOINIT ) THEN
+*
+*        Initialize V.
+*
+         DO 30 I = 1, N
+            V( I ) = EPS3
+   30    CONTINUE
+      ELSE
+*
+*        Scale supplied initial vector.
+*
+         VNORM = DZNRM2( N, V, 1 )
+         CALL ZDSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), V, 1 )
+      END IF
+*
+      IF( RIGHTV ) THEN
+*
+*        LU decomposition with partial pivoting of B, replacing zero
+*        pivots by EPS3.
+*
+         DO 60 I = 1, N - 1
+            EI = H( I+1, I )
+            IF( CABS1( B( I, I ) ).LT.CABS1( EI ) ) THEN
+*
+*              Interchange rows and eliminate.
+*
+               X = ZLADIV( B( I, I ), EI )
+               B( I, I ) = EI
+               DO 40 J = I + 1, N
+                  TEMP = B( I+1, J )
+                  B( I+1, J ) = B( I, J ) - X*TEMP
+                  B( I, J ) = TEMP
+   40          CONTINUE
+            ELSE
+*
+*              Eliminate without interchange.
+*
+               IF( B( I, I ).EQ.ZERO )
+     $            B( I, I ) = EPS3
+               X = ZLADIV( EI, B( I, I ) )
+               IF( X.NE.ZERO ) THEN
+                  DO 50 J = I + 1, N
+                     B( I+1, J ) = B( I+1, J ) - X*B( I, J )
+   50             CONTINUE
+               END IF
+            END IF
+   60    CONTINUE
+         IF( B( N, N ).EQ.ZERO )
+     $      B( N, N ) = EPS3
+*
+         TRANS = 'N'
+*
+      ELSE
+*
+*        UL decomposition with partial pivoting of B, replacing zero
+*        pivots by EPS3.
+*
+         DO 90 J = N, 2, -1
+            EJ = H( J, J-1 )
+            IF( CABS1( B( J, J ) ).LT.CABS1( EJ ) ) THEN
+*
+*              Interchange columns and eliminate.
+*
+               X = ZLADIV( B( J, J ), EJ )
+               B( J, J ) = EJ
+               DO 70 I = 1, J - 1
+                  TEMP = B( I, J-1 )
+                  B( I, J-1 ) = B( I, J ) - X*TEMP
+                  B( I, J ) = TEMP
+   70          CONTINUE
+            ELSE
+*
+*              Eliminate without interchange.
+*
+               IF( B( J, J ).EQ.ZERO )
+     $            B( J, J ) = EPS3
+               X = ZLADIV( EJ, B( J, J ) )
+               IF( X.NE.ZERO ) THEN
+                  DO 80 I = 1, J - 1
+                     B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
+   80             CONTINUE
+               END IF
+            END IF
+   90    CONTINUE
+         IF( B( 1, 1 ).EQ.ZERO )
+     $      B( 1, 1 ) = EPS3
+*
+         TRANS = 'C'
+*
+      END IF
+*
+      NORMIN = 'N'
+      DO 110 ITS = 1, N
+*
+*        Solve U*x = scale*v for a right eigenvector
+*          or U'*x = scale*v for a left eigenvector,
+*        overwriting x on v.
+*
+         CALL ZLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB, V,
+     $                SCALE, RWORK, IERR )
+         NORMIN = 'Y'
+*
+*        Test for sufficient growth in the norm of v.
+*
+         VNORM = DZASUM( N, V, 1 )
+         IF( VNORM.GE.GROWTO*SCALE )
+     $      GO TO 120
+*
+*        Choose new orthogonal starting vector and try again.
+*
+         RTEMP = EPS3 / ( ROOTN+ONE )
+         V( 1 ) = EPS3
+         DO 100 I = 2, N
+            V( I ) = RTEMP
+  100    CONTINUE
+         V( N-ITS+1 ) = V( N-ITS+1 ) - EPS3*ROOTN
+  110 CONTINUE
+*
+*     Failure to find eigenvector in N iterations.
+*
+      INFO = 1
+*
+  120 CONTINUE
+*
+*     Normalize eigenvector.
+*
+      I = IZAMAX( N, V, 1 )
+      CALL ZDSCAL( N, ONE / CABS1( V( I ) ), V, 1 )
+*
+      RETURN
+*
+*     End of ZLAEIN
+*
+      END
diff --git a/SRC/zlaesy.f b/SRC/zlaesy.f
new file mode 100644
index 00000000..43b76705
--- /dev/null
+++ b/SRC/zlaesy.f
@@ -0,0 +1,152 @@
+      SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      COMPLEX*16         A, B, C, CS1, EVSCAL, RT1, RT2, SN1
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix
+*     ( ( A, B );( B, C ) )
+*  provided the norm of the matrix of eigenvectors is larger than
+*  some threshold value.
+*
+*  RT1 is the eigenvalue of larger absolute value, and RT2 of
+*  smaller absolute value.  If the eigenvectors are computed, then
+*  on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence
+*
+*  [  CS1     SN1   ] . [ A  B ] . [ CS1    -SN1   ] = [ RT1  0  ]
+*  [ -SN1     CS1   ]   [ B  C ]   [ SN1     CS1   ]   [  0  RT2 ]
+*
+*  Arguments
+*  =========
+*
+*  A       (input) COMPLEX*16
+*          The ( 1, 1 ) element of input matrix.
+*
+*  B       (input) COMPLEX*16
+*          The ( 1, 2 ) element of input matrix.  The ( 2, 1 ) element
+*          is also given by B, since the 2-by-2 matrix is symmetric.
+*
+*  C       (input) COMPLEX*16
+*          The ( 2, 2 ) element of input matrix.
+*
+*  RT1     (output) COMPLEX*16
+*          The eigenvalue of larger modulus.
+*
+*  RT2     (output) COMPLEX*16
+*          The eigenvalue of smaller modulus.
+*
+*  EVSCAL  (output) COMPLEX*16
+*          The complex value by which the eigenvector matrix was scaled
+*          to make it orthonormal.  If EVSCAL is zero, the eigenvectors
+*          were not computed.  This means one of two things:  the 2-by-2
+*          matrix could not be diagonalized, or the norm of the matrix
+*          of eigenvectors before scaling was larger than the threshold
+*          value THRESH (set below).
+*
+*  CS1     (output) COMPLEX*16
+*  SN1     (output) COMPLEX*16
+*          If EVSCAL .NE. 0,  ( CS1, SN1 ) is the unit right eigenvector
+*          for RT1.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
+      DOUBLE PRECISION   HALF
+      PARAMETER          ( HALF = 0.5D0 )
+      DOUBLE PRECISION   THRESH
+      PARAMETER          ( THRESH = 0.1D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   BABS, EVNORM, TABS, Z
+      COMPLEX*16         S, T, TMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*
+*     Special case:  The matrix is actually diagonal.
+*     To avoid divide by zero later, we treat this case separately.
+*
+      IF( ABS( B ).EQ.ZERO ) THEN
+         RT1 = A
+         RT2 = C
+         IF( ABS( RT1 ).LT.ABS( RT2 ) ) THEN
+            TMP = RT1
+            RT1 = RT2
+            RT2 = TMP
+            CS1 = ZERO
+            SN1 = ONE
+         ELSE
+            CS1 = ONE
+            SN1 = ZERO
+         END IF
+      ELSE
+*
+*        Compute the eigenvalues and eigenvectors.
+*        The characteristic equation is
+*           lambda **2 - (A+C) lambda + (A*C - B*B)
+*        and we solve it using the quadratic formula.
+*
+         S = ( A+C )*HALF
+         T = ( A-C )*HALF
+*
+*        Take the square root carefully to avoid over/under flow.
+*
+         BABS = ABS( B )
+         TABS = ABS( T )
+         Z = MAX( BABS, TABS )
+         IF( Z.GT.ZERO )
+     $      T = Z*SQRT( ( T / Z )**2+( B / Z )**2 )
+*
+*        Compute the two eigenvalues.  RT1 and RT2 are exchanged
+*        if necessary so that RT1 will have the greater magnitude.
+*
+         RT1 = S + T
+         RT2 = S - T
+         IF( ABS( RT1 ).LT.ABS( RT2 ) ) THEN
+            TMP = RT1
+            RT1 = RT2
+            RT2 = TMP
+         END IF
+*
+*        Choose CS1 = 1 and SN1 to satisfy the first equation, then
+*        scale the components of this eigenvector so that the matrix
+*        of eigenvectors X satisfies  X * X' = I .  (No scaling is
+*        done if the norm of the eigenvalue matrix is less than THRESH.)
+*
+         SN1 = ( RT1-A ) / B
+         TABS = ABS( SN1 )
+         IF( TABS.GT.ONE ) THEN
+            T = TABS*SQRT( ( ONE / TABS )**2+( SN1 / TABS )**2 )
+         ELSE
+            T = SQRT( CONE+SN1*SN1 )
+         END IF
+         EVNORM = ABS( T )
+         IF( EVNORM.GE.THRESH ) THEN
+            EVSCAL = CONE / T
+            CS1 = EVSCAL
+            SN1 = SN1*EVSCAL
+         ELSE
+            EVSCAL = ZERO
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLAESY
+*
+      END
diff --git a/SRC/zlaev2.f b/SRC/zlaev2.f
new file mode 100644
index 00000000..0fa81cba
--- /dev/null
+++ b/SRC/zlaev2.f
@@ -0,0 +1,95 @@
+      SUBROUTINE ZLAEV2( 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   CS1, RT1, RT2
+      COMPLEX*16         A, B, C, SN1
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
+*     [  A         B  ]
+*     [  CONJG(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  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]
+*  [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].
+*
+*  Arguments
+*  =========
+*
+*  A      (input) COMPLEX*16
+*         The (1,1) element of the 2-by-2 matrix.
+*
+*  B      (input) COMPLEX*16
+*         The (1,2) element and the conjugate of the (2,1) element of
+*         the 2-by-2 matrix.
+*
+*  C      (input) COMPLEX*16
+*         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) COMPLEX*16
+*         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   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   T
+      COMPLEX*16         W
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAEV2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ABS( B ).EQ.ZERO ) THEN
+         W = ONE
+      ELSE
+         W = DCONJG( B ) / ABS( B )
+      END IF
+      CALL DLAEV2( DBLE( A ), ABS( B ), DBLE( C ), RT1, RT2, CS1, T )
+      SN1 = W*T
+      RETURN
+*
+*     End of ZLAEV2
+*
+      END
diff --git a/SRC/zlag2c.f b/SRC/zlag2c.f
new file mode 100644
index 00000000..d47ca5ba
--- /dev/null
+++ b/SRC/zlag2c.f
@@ -0,0 +1,93 @@
+      SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO)
+*
+*  -- LAPACK PROTOTYPE auxilary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     ..
+*     .. WARNING: PROTOTYPE ..
+*     This is an LAPACK PROTOTYPE routine which means that the
+*     interface of this routine is likely to be changed in the future
+*     based on community feedback.
+*
+*     ..
+*     .. Scalar Arguments ..
+      INTEGER INFO,LDA,LDSA,M,N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX SA(LDSA,*)
+      COMPLEX*16 A(LDA,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAG2C converts a DOUBLE PRECISION COMPLEX matrix, SA, to a SINGLE
+*  PRECISION COMPLEX matrix, A.
+*
+*  RMAX is the overflow for the SINGLE PRECISION arithmetic
+*  ZLAG2C checks that all the entries of A are between -RMAX and
+*  RMAX. If not the convertion is aborted and a flag is raised.
+*
+*  This is a helper routine so there is no argument checking.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of lines 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)
+*          On entry, the M-by-N coefficient matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  SA      (output) REAL array, dimension (LDSA,N)
+*          On exit, if INFO=0, the M-by-N coefficient matrix SA.
+*
+*  LDSA    (input) INTEGER
+*          The leading dimension of the array SA.  LDSA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          > 0:  if INFO = k, the (i,j) entry of the matrix A has
+*                overflowed when moving from DOUBLE PRECISION to SINGLE
+*                k is given by k = (i-1)*LDA+j
+*
+*  =========
+*
+*     .. Local Scalars ..
+      INTEGER I,J
+      DOUBLE PRECISION RMAX
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC DBLE, DIMAG
+*     ..
+*     .. External Functions ..
+      REAL SLAMCH
+      EXTERNAL SLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      RMAX = SLAMCH('O')
+      DO 20 J = 1,N
+          DO 30 I = 1,M
+              IF  ((DBLE(A(I,J)).LT.-RMAX) .OR. (DBLE(A(I,J)).GT.RMAX)
+     $      .OR. (DIMAG(A(I,J)).LT.-RMAX) .OR. (DIMAG(A(I,J)).GT.RMAX))
+     $      THEN
+                  INFO = (I-1)*LDA + J
+                  GO TO 10
+              END IF
+              SA(I,J) = A(I,J)
+   30     CONTINUE
+   20 CONTINUE
+   10 CONTINUE
+      RETURN
+*
+*     End of ZLAG2C
+*
+      END
diff --git a/SRC/zlags2.f b/SRC/zlags2.f
new file mode 100644
index 00000000..293f75e4
--- /dev/null
+++ b/SRC/zlags2.f
@@ -0,0 +1,308 @@
+      SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
+     $                   SNV, CSQ, SNQ )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            UPPER
+      DOUBLE PRECISION   A1, A3, B1, B3, CSQ, CSU, CSV
+      COMPLEX*16         A2, B2, SNQ, SNU, SNV
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such
+*  that if ( UPPER ) then
+*
+*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
+*                        ( 0  A3 )     ( x  x  )
+*  and
+*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
+*                        ( 0  B3 )     ( x  x  )
+*
+*  or if ( .NOT.UPPER ) then
+*
+*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
+*                        ( A2 A3 )     ( 0  x  )
+*  and
+*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
+*                        ( B2 B3 )     ( 0  x  )
+*  where
+*
+*    U = (     CSU      SNU ), V = (     CSV     SNV ),
+*        ( -CONJG(SNU)  CSU )      ( -CONJG(SNV) CSV )
+*
+*    Q = (     CSQ      SNQ )
+*        ( -CONJG(SNQ)  CSQ )
+*
+*  Z' denotes the conjugate transpose of Z.
+*
+*  The rows of the transformed A and B are parallel. Moreover, if the
+*  input 2-by-2 matrix A is not zero, then the transformed (1,1) entry
+*  of A is not zero. If the input matrices A and B are both not zero,
+*  then the transformed (2,2) element of B is not zero, except when the
+*  first rows of input A and B are parallel and the second rows are
+*  zero.
+*
+*  Arguments
+*  =========
+*
+*  UPPER   (input) LOGICAL
+*          = .TRUE.: the input matrices A and B are upper triangular.
+*          = .FALSE.: the input matrices A and B are lower triangular.
+*
+*  A1      (input) DOUBLE PRECISION
+*  A2      (input) COMPLEX*16
+*  A3      (input) DOUBLE PRECISION
+*          On entry, A1, A2 and A3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix A.
+*
+*  B1      (input) DOUBLE PRECISION
+*  B2      (input) COMPLEX*16
+*  B3      (input) DOUBLE PRECISION
+*          On entry, B1, B2 and B3 are elements of the input 2-by-2
+*          upper (lower) triangular matrix B.
+*
+*  CSU     (output) DOUBLE PRECISION
+*  SNU     (output) COMPLEX*16
+*          The desired unitary matrix U.
+*
+*  CSV     (output) DOUBLE PRECISION
+*  SNV     (output) COMPLEX*16
+*          The desired unitary matrix V.
+*
+*  CSQ     (output) DOUBLE PRECISION
+*  SNQ     (output) COMPLEX*16
+*          The desired unitary matrix Q.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   A, AUA11, AUA12, AUA21, AUA22, AVB12, AVB11, 
+     $                   AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2, 
+     $                   SNL, SNR, UA11R, UA22R, VB11R, VB22R
+      COMPLEX*16         B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
+     $                   VB12, VB21, VB22
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASV2, ZLARTG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( T ) = ABS( DBLE( T ) ) + ABS( DIMAG( T ) )
+*     ..
+*     .. Executable Statements ..
+*
+      IF( UPPER ) THEN
+*
+*        Input matrices A and B are upper triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a b )
+*                                   ( 0 d )
+*
+         A = A1*B3
+         D = A3*B1
+         B = A2*B1 - A1*B2
+         FB = ABS( B )
+*
+*        Transform complex 2-by-2 matrix C to real matrix by unitary
+*        diagonal matrix diag(1,D1).
+*
+         D1 = ONE
+         IF( FB.NE.ZERO )
+     $      D1 = B / FB
+*
+*        The SVD of real 2 by 2 triangular C
+*
+*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL DLASV2( A, FB, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
+     $        THEN
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11R = CSL*A1
+            UA12 = CSL*A2 + D1*SNL*A3
+*
+            VB11R = CSR*B1
+            VB12 = CSR*B2 + D1*SNR*B3
+*
+            AUA12 = ABS( CSL )*ABS1( A2 ) + ABS( SNL )*ABS( A3 )
+            AVB12 = ABS( CSR )*ABS1( B2 ) + ABS( SNR )*ABS( B3 )
+*
+*           zero (1,2) elements of U'*A and V'*B
+*
+            IF( ( ABS( UA11R )+ABS1( UA12 ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( -DCMPLX( VB11R ), DCONJG( VB12 ), CSQ, SNQ,
+     $                      R )
+            ELSE IF( ( ABS( VB11R )+ABS1( VB12 ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( -DCMPLX( UA11R ), DCONJG( UA12 ), CSQ, SNQ,
+     $                      R )
+            ELSE IF( AUA12 / ( ABS( UA11R )+ABS1( UA12 ) ).LE.AVB12 /
+     $               ( ABS( VB11R )+ABS1( VB12 ) ) ) THEN
+               CALL ZLARTG( -DCMPLX( UA11R ), DCONJG( UA12 ), CSQ, SNQ,
+     $                      R )
+            ELSE
+               CALL ZLARTG( -DCMPLX( VB11R ), DCONJG( VB12 ), CSQ, SNQ,
+     $                      R )
+            END IF
+*
+            CSU = CSL
+            SNU = -D1*SNL
+            CSV = CSR
+            SNV = -D1*SNR
+*
+         ELSE
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,2) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -DCONJG( D1 )*SNL*A1
+            UA22 = -DCONJG( D1 )*SNL*A2 + CSL*A3
+*
+            VB21 = -DCONJG( D1 )*SNR*B1
+            VB22 = -DCONJG( D1 )*SNR*B2 + CSR*B3
+*
+            AUA22 = ABS( SNL )*ABS1( A2 ) + ABS( CSL )*ABS( A3 )
+            AVB22 = ABS( SNR )*ABS1( B2 ) + ABS( CSR )*ABS( B3 )
+*
+*           zero (2,2) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS1( UA21 )+ABS1( UA22 ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( -DCONJG( VB21 ), DCONJG( VB22 ), CSQ, SNQ,
+     $                      R )
+            ELSE IF( ( ABS1( VB21 )+ABS( VB22 ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( -DCONJG( UA21 ), DCONJG( UA22 ), CSQ, SNQ,
+     $                      R )
+            ELSE IF( AUA22 / ( ABS1( UA21 )+ABS1( UA22 ) ).LE.AVB22 /
+     $               ( ABS1( VB21 )+ABS1( VB22 ) ) ) THEN
+               CALL ZLARTG( -DCONJG( UA21 ), DCONJG( UA22 ), CSQ, SNQ,
+     $                      R )
+            ELSE
+               CALL ZLARTG( -DCONJG( VB21 ), DCONJG( VB22 ), CSQ, SNQ,
+     $                      R )
+            END IF
+*
+            CSU = SNL
+            SNU = D1*CSL
+            CSV = SNR
+            SNV = D1*CSR
+*
+         END IF
+*
+      ELSE
+*
+*        Input matrices A and B are lower triangular matrices
+*
+*        Form matrix C = A*adj(B) = ( a 0 )
+*                                   ( c d )
+*
+         A = A1*B3
+         D = A3*B1
+         C = A2*B3 - A3*B2
+         FC = ABS( C )
+*
+*        Transform complex 2-by-2 matrix C to real matrix by unitary
+*        diagonal matrix diag(d1,1).
+*
+         D1 = ONE
+         IF( FC.NE.ZERO )
+     $      D1 = C / FC
+*
+*        The SVD of real 2 by 2 triangular C
+*
+*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
+*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
+*
+         CALL DLASV2( A, FC, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
+     $        THEN
+*
+*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+*           and (2,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA21 = -D1*SNR*A1 + CSR*A2
+            UA22R = CSR*A3
+*
+            VB21 = -D1*SNL*B1 + CSL*B2
+            VB22R = CSL*B3
+*
+            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS1( A2 )
+            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS1( B2 )
+*
+*           zero (2,1) elements of U'*A and V'*B.
+*
+            IF( ( ABS1( UA21 )+ABS( UA22R ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( DCMPLX( VB22R ), VB21, CSQ, SNQ, R )
+            ELSE IF( ( ABS1( VB21 )+ABS( VB22R ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( DCMPLX( UA22R ), UA21, CSQ, SNQ, R )
+            ELSE IF( AUA21 / ( ABS1( UA21 )+ABS( UA22R ) ).LE.AVB21 /
+     $               ( ABS1( VB21 )+ABS( VB22R ) ) ) THEN
+               CALL ZLARTG( DCMPLX( UA22R ), UA21, CSQ, SNQ, R )
+            ELSE
+               CALL ZLARTG( DCMPLX( VB22R ), VB21, CSQ, SNQ, R )
+            END IF
+*
+            CSU = CSR
+            SNU = -DCONJG( D1 )*SNR
+            CSV = CSL
+            SNV = -DCONJG( D1 )*SNL
+*
+         ELSE
+*
+*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+*           and (1,1) element of |U|'*|A| and |V|'*|B|.
+*
+            UA11 = CSR*A1 + DCONJG( D1 )*SNR*A2
+            UA12 = DCONJG( D1 )*SNR*A3
+*
+            VB11 = CSL*B1 + DCONJG( D1 )*SNL*B2
+            VB12 = DCONJG( D1 )*SNL*B3
+*
+            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS1( A2 )
+            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS1( B2 )
+*
+*           zero (1,1) elements of U'*A and V'*B, and then swap.
+*
+            IF( ( ABS1( UA11 )+ABS1( UA12 ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( VB12, VB11, CSQ, SNQ, R )
+            ELSE IF( ( ABS1( VB11 )+ABS1( VB12 ) ).EQ.ZERO ) THEN
+               CALL ZLARTG( UA12, UA11, CSQ, SNQ, R )
+            ELSE IF( AUA11 / ( ABS1( UA11 )+ABS1( UA12 ) ).LE.AVB11 /
+     $               ( ABS1( VB11 )+ABS1( VB12 ) ) ) THEN
+               CALL ZLARTG( UA12, UA11, CSQ, SNQ, R )
+            ELSE
+               CALL ZLARTG( VB12, VB11, CSQ, SNQ, R )
+            END IF
+*
+            CSU = SNR
+            SNU = DCONJG( D1 )*CSR
+            CSV = SNL
+            SNV = DCONJG( D1 )*CSL
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of ZLAGS2
+*
+      END
diff --git a/SRC/zlagtm.f b/SRC/zlagtm.f
new file mode 100644
index 00000000..eb846530
--- /dev/null
+++ b/SRC/zlagtm.f
@@ -0,0 +1,233 @@
+      SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
+     $                   B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            LDB, LDX, N, NRHS
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         B( LDB, * ), D( * ), DL( * ), DU( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAGTM performs a matrix-vector product of the form
+*
+*     B := alpha * A * X + beta * B
+*
+*  where A is a tridiagonal matrix of order N, B and X are N by NRHS
+*  matrices, and alpha and beta are real scalars, each of which may be
+*  0., 1., or -1.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the operation applied to A.
+*          = 'N':  No transpose, B := alpha * A * X + beta * B
+*          = 'T':  Transpose,    B := alpha * A**T * X + beta * B
+*          = 'C':  Conjugate transpose, B := alpha * A**H * X + beta * B
+*
+*  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 X and B.
+*
+*  ALPHA   (input) DOUBLE PRECISION
+*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 0.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of T.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The diagonal elements of T.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) super-diagonal elements of T.
+*
+*  X       (input) COMPLEX*16 array, dimension (LDX,NRHS)
+*          The N by NRHS matrix X.
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(N,1).
+*
+*  BETA    (input) DOUBLE PRECISION
+*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
+*          it is assumed to be 1.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the N by NRHS matrix B.
+*          On exit, B is overwritten by the matrix expression
+*          B := alpha * A * X + beta * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(N,1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Multiply B by BETA if BETA.NE.1.
+*
+      IF( BETA.EQ.ZERO ) THEN
+         DO 20 J = 1, NRHS
+            DO 10 I = 1, N
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( BETA.EQ.-ONE ) THEN
+         DO 40 J = 1, NRHS
+            DO 30 I = 1, N
+               B( I, J ) = -B( I, J )
+   30       CONTINUE
+   40    CONTINUE
+      END IF
+*
+      IF( ALPHA.EQ.ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B + A*X
+*
+            DO 60 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 50 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DU( I )*X( I+1, J )
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Compute B := B + A**T * X
+*
+            DO 80 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
+     $                        D( N )*X( N, J )
+                  DO 70 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
+     $                           D( I )*X( I, J ) + DL( I )*X( I+1, J )
+   70             CONTINUE
+               END IF
+   80       CONTINUE
+         ELSE IF( LSAME( TRANS, 'C' ) ) THEN
+*
+*           Compute B := B + A**H * X
+*
+            DO 100 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) + DCONJG( D( 1 ) )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) + DCONJG( D( 1 ) )*X( 1, J ) +
+     $                        DCONJG( DL( 1 ) )*X( 2, J )
+                  B( N, J ) = B( N, J ) + DCONJG( DU( N-1 ) )*
+     $                        X( N-1, J ) + DCONJG( D( N ) )*X( N, J )
+                  DO 90 I = 2, N - 1
+                     B( I, J ) = B( I, J ) + DCONJG( DU( I-1 ) )*
+     $                           X( I-1, J ) + DCONJG( D( I ) )*
+     $                           X( I, J ) + DCONJG( DL( I ) )*
+     $                           X( I+1, J )
+   90             CONTINUE
+               END IF
+  100       CONTINUE
+         END IF
+      ELSE IF( ALPHA.EQ.-ONE ) THEN
+         IF( LSAME( TRANS, 'N' ) ) THEN
+*
+*           Compute B := B - A*X
+*
+            DO 120 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DU( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 110 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DU( I )*X( I+1, J )
+  110             CONTINUE
+               END IF
+  120       CONTINUE
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Compute B := B - A'*X
+*
+            DO 140 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+     $                        DL( 1 )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
+     $                        D( N )*X( N, J )
+                  DO 130 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
+     $                           D( I )*X( I, J ) - DL( I )*X( I+1, J )
+  130             CONTINUE
+               END IF
+  140       CONTINUE
+         ELSE IF( LSAME( TRANS, 'C' ) ) THEN
+*
+*           Compute B := B - A'*X
+*
+            DO 160 J = 1, NRHS
+               IF( N.EQ.1 ) THEN
+                  B( 1, J ) = B( 1, J ) - DCONJG( D( 1 ) )*X( 1, J )
+               ELSE
+                  B( 1, J ) = B( 1, J ) - DCONJG( D( 1 ) )*X( 1, J ) -
+     $                        DCONJG( DL( 1 ) )*X( 2, J )
+                  B( N, J ) = B( N, J ) - DCONJG( DU( N-1 ) )*
+     $                        X( N-1, J ) - DCONJG( D( N ) )*X( N, J )
+                  DO 150 I = 2, N - 1
+                     B( I, J ) = B( I, J ) - DCONJG( DU( I-1 ) )*
+     $                           X( I-1, J ) - DCONJG( D( I ) )*
+     $                           X( I, J ) - DCONJG( DL( I ) )*
+     $                           X( I+1, J )
+  150             CONTINUE
+               END IF
+  160       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLAGTM
+*
+      END
diff --git a/SRC/zlahef.f b/SRC/zlahef.f
new file mode 100644
index 00000000..3b1041ff
--- /dev/null
+++ b/SRC/zlahef.f
@@ -0,0 +1,647 @@
+      SUBROUTINE ZLAHEF( 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( * )
+      COMPLEX*16         A( LDA, * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAHEF computes a partial factorization of a complex Hermitian
+*  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.
+*  Note that U' denotes the conjugate transpose of U.
+*
+*  ZLAHEF is an auxiliary routine called by ZHETRF. 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
+*          Hermitian 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) 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, 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) COMPLEX*16 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 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.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, R1, ROWMAX, T
+      COMPLEX*16         D11, D21, D22, Z
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      EXTERNAL           LSAME, IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+*     ..
+*     .. 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 (note that conjg(W) is actually stored)
+*
+*        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 ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
+         W( K, KW ) = DBLE( A( K, K ) )
+         IF( K.LT.N ) THEN
+            CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+     $                  W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+            W( K, KW ) = DBLE( W( K, KW ) )
+         END IF
+*
+         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( DBLE( 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 = IZAMAX( K-1, W( 1, KW ), 1 )
+            COLMAX = CABS1( 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
+            A( K, K ) = DBLE( A( K, 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 ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+               W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) )
+               CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+     $                     W( IMAX+1, KW-1 ), 1 )
+               CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               IF( K.LT.N ) THEN
+                  CALL ZGEMV( 'No transpose', K, N-K, -CONE,
+     $                        A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+     $                        CONE, W( 1, KW-1 ), 1 )
+                  W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) )
+               END IF
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, KW-1 ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( DBLE( 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 ZCOPY( 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, KP ) = DBLE( A( KK, KK ) )
+               CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
+               CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+*              Interchange rows KK and KP in last KK columns of A and W
+*
+               IF( KK.LT.N )
+     $            CALL ZSWAP( N-KK, A( KK, KK+1 ), LDA, A( KP, KK+1 ),
+     $                        LDA )
+               CALL ZSWAP( 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 ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+               R1 = ONE / DBLE( A( K, K ) )
+               CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
+*
+*              Conjugate W(k)
+*
+               CALL ZLACGV( K-1, W( 1, KW ), 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 ) / DCONJG( D21 )
+                  D22 = W( K-1, KW-1 ) / D21
+                  T = ONE / ( DBLE( 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 ) = DCONJG( 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 )
+*
+*              Conjugate W(k) and W(k-1)
+*
+               CALL ZLACGV( K-1, W( 1, KW ), 1 )
+               CALL ZLACGV( K-2, W( 1, KW-1 ), 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
+*
+*        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 (note that conjg(W) is
+*        actually stored)
+*
+         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
+               A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+               CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+     $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+     $                     A( J, JJ ), 1 )
+               A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+   40       CONTINUE
+*
+*           Update the rectangular superdiagonal block
+*
+            CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+     $                  -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+     $                  CONE, 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 ZSWAP( 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 (note that conjg(W) is actually stored)
+*
+*        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
+*
+         W( K, K ) = DBLE( A( K, K ) )
+         IF( K.LT.N )
+     $      CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
+         CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
+     $               W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+         W( K, K ) = DBLE( W( K, K ) )
+*
+         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( DBLE( 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 + IZAMAX( N-K, W( K+1, K ), 1 )
+            COLMAX = CABS1( 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
+            A( K, K ) = DBLE( A( K, 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 ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+               CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 )
+               W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) )
+               IF( IMAX.LT.N )
+     $            CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
+     $                        W( IMAX+1, K+1 ), 1 )
+               CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+     $                     LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ),
+     $                     1 )
+               W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) )
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, K+1 ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( DBLE( 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 ZCOPY( 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, KP ) = DBLE( A( KK, KK ) )
+               CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+     $                     LDA )
+               CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
+               IF( KP.LT.N )
+     $            CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+*
+*              Interchange rows KK and KP in first KK columns of A and W
+*
+               CALL ZSWAP( KK-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+               CALL ZSWAP( 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 ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+               IF( K.LT.N ) THEN
+                  R1 = ONE / DBLE( A( K, K ) )
+                  CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
+*
+*                 Conjugate W(k)
+*
+                  CALL ZLACGV( N-K, W( 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 ) / DCONJG( D21 )
+                  T = ONE / ( DBLE( D11*D22 )-ONE )
+                  D21 = T / D21
+                  DO 80 J = K + 2, N
+                     A( J, K ) = DCONJG( 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 )
+*
+*              Conjugate W(k) and W(k+1)
+*
+               CALL ZLACGV( N-K, W( K+1, K ), 1 )
+               CALL ZLACGV( N-K-1, W( K+2, K+1 ), 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 (note that conjg(W) is
+*        actually stored)
+*
+         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
+               A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+               CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+     $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+     $                     A( JJ, JJ ), 1 )
+               A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+  100       CONTINUE
+*
+*           Update the rectangular subdiagonal block
+*
+            IF( J+JB.LE.N )
+     $         CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+     $                     K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+     $                     LDW, CONE, 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 ZSWAP( 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 ZLAHEF
+*
+      END
diff --git a/SRC/zlahqr.f b/SRC/zlahqr.f
new file mode 100644
index 00000000..9ce9be19
--- /dev/null
+++ b/SRC/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/zlahr2.f b/SRC/zlahr2.f
new file mode 100644
index 00000000..f3cb5515
--- /dev/null
+++ b/SRC/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/zlahrd.f b/SRC/zlahrd.f
new file mode 100644
index 00000000..e7eb9de9
--- /dev/null
+++ b/SRC/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/zlaic1.f b/SRC/zlaic1.f
new file mode 100644
index 00000000..589f0889
--- /dev/null
+++ b/SRC/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/zlals0.f b/SRC/zlals0.f
new file mode 100644
index 00000000..9d419612
--- /dev/null
+++ b/SRC/zlals0.f
@@ -0,0 +1,433 @@
+      SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
+     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
+     $                   POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
+     $                   LDGNUM, NL, NR, NRHS, SQRE
+      DOUBLE PRECISION   C, S
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
+      DOUBLE PRECISION   DIFL( * ), DIFR( LDGNUM, * ),
+     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
+     $                   RWORK( * ), Z( * )
+      COMPLEX*16         B( LDB, * ), BX( LDBX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLALS0 applies back the multiplying factors of either the left or the
+*  right singular vector matrix of a diagonal matrix appended by a row
+*  to the right hand side matrix B in solving the least squares problem
+*  using the divide-and-conquer SVD approach.
+*
+*  For the left singular vector matrix, three types of orthogonal
+*  matrices are involved:
+*
+*  (1L) Givens rotations: the number of such rotations is GIVPTR; the
+*       pairs of columns/rows they were applied to are stored in GIVCOL;
+*       and the C- and S-values of these rotations are stored in GIVNUM.
+*
+*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
+*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the
+*       J-th row.
+*
+*  (3L) The left singular vector matrix of the remaining matrix.
+*
+*  For the right singular vector matrix, four types of orthogonal
+*  matrices are involved:
+*
+*  (1R) The right singular vector matrix of the remaining matrix.
+*
+*  (2R) If SQRE = 1, one extra Givens rotation to generate the right
+*       null space.
+*
+*  (3R) The inverse transformation of (2L).
+*
+*  (4R) The inverse transformation of (1L).
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether singular vectors are to be computed in
+*         factored form:
+*         = 0: Left singular vector matrix.
+*         = 1: Right singular vector matrix.
+*
+*  NL     (input) INTEGER
+*         The row dimension of the upper block. NL >= 1.
+*
+*  NR     (input) INTEGER
+*         The row dimension of the lower block. NR >= 1.
+*
+*  SQRE   (input) INTEGER
+*         = 0: the lower block is an NR-by-NR square matrix.
+*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+*         The bidiagonal matrix has row dimension N = NL + NR + 1,
+*         and column dimension M = N + SQRE.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M. On output, B contains
+*         the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B. LDB must be at least
+*         max(1,MAX( M, N ) ).
+*
+*  BX     (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS )
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  PERM   (input) INTEGER array, dimension ( N )
+*         The permutations (from deflation and sorting) applied
+*         to the two blocks.
+*
+*  GIVPTR (input) INTEGER
+*         The number of Givens rotations which took place in this
+*         subproblem.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
+*         Each pair of numbers indicates a pair of rows/columns
+*         involved in a Givens rotation.
+*
+*  LDGCOL (input) INTEGER
+*         The leading dimension of GIVCOL, must be at least N.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         Each number indicates the C or S value used in the
+*         corresponding Givens rotation.
+*
+*  LDGNUM (input) INTEGER
+*         The leading dimension of arrays DIFR, POLES and
+*         GIVNUM, must be at least K.
+*
+*  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+*         On entry, POLES(1:K, 1) contains the new singular
+*         values obtained from solving the secular equation, and
+*         POLES(1:K, 2) is an array containing the poles in the secular
+*         equation.
+*
+*  DIFL   (input) DOUBLE PRECISION array, dimension ( K ).
+*         On entry, DIFL(I) is the distance between I-th updated
+*         (undeflated) singular value and the I-th (undeflated) old
+*         singular value.
+*
+*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
+*         On entry, DIFR(I, 1) contains the distances between I-th
+*         updated (undeflated) singular value and the I+1-th
+*         (undeflated) old singular value. And DIFR(I, 2) is the
+*         normalizing factor for the I-th right singular vector.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( K )
+*         Contain the components of the deflation-adjusted updating row
+*         vector.
+*
+*  K      (input) INTEGER
+*         Contains the dimension of the non-deflated matrix,
+*         This is the order of the related secular equation. 1 <= K <=N.
+*
+*  C      (input) DOUBLE PRECISION
+*         C contains garbage if SQRE =0 and the C-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  S      (input) DOUBLE PRECISION
+*         S contains garbage if SQRE =0 and the S-value of a Givens
+*         rotation related to the right null space if SQRE = 1.
+*
+*  RWORK  (workspace) DOUBLE PRECISION array, dimension
+*         ( K*(1+NRHS) + 2*NRHS )
+*
+*  INFO   (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO, NEGONE
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JCOL, JROW, M, N, NLP1
+      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, XERBLA, ZCOPY, ZDROT, ZDSCAL, ZLACPY,
+     $                   ZLASCL
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3, DNRM2
+      EXTERNAL           DLAMC3, DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DIMAG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( NL.LT.1 ) THEN
+         INFO = -2
+      ELSE IF( NR.LT.1 ) THEN
+         INFO = -3
+      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+         INFO = -4
+      END IF
+*
+      N = NL + NR + 1
+*
+      IF( NRHS.LT.1 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -7
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -9
+      ELSE IF( GIVPTR.LT.0 ) THEN
+         INFO = -11
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -13
+      ELSE IF( LDGNUM.LT.N ) THEN
+         INFO = -15
+      ELSE IF( K.LT.1 ) THEN
+         INFO = -20
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLALS0', -INFO )
+         RETURN
+      END IF
+*
+      M = N + SQRE
+      NLP1 = NL + 1
+*
+      IF( ICOMPQ.EQ.0 ) THEN
+*
+*        Apply back orthogonal transformations from the left.
+*
+*        Step (1L): apply back the Givens rotations performed.
+*
+         DO 10 I = 1, GIVPTR
+            CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                  GIVNUM( I, 1 ) )
+   10    CONTINUE
+*
+*        Step (2L): permute rows of B.
+*
+         CALL ZCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
+         DO 20 I = 2, N
+            CALL ZCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
+   20    CONTINUE
+*
+*        Step (3L): apply the inverse of the left singular vector
+*        matrix to BX.
+*
+         IF( K.EQ.1 ) THEN
+            CALL ZCOPY( NRHS, BX, LDBX, B, LDB )
+            IF( Z( 1 ).LT.ZERO ) THEN
+               CALL ZDSCAL( NRHS, NEGONE, B, LDB )
+            END IF
+         ELSE
+            DO 100 J = 1, K
+               DIFLJ = DIFL( J )
+               DJ = POLES( J, 1 )
+               DSIGJ = -POLES( J, 2 )
+               IF( J.LT.K ) THEN
+                  DIFRJ = -DIFR( J, 1 )
+                  DSIGJP = -POLES( J+1, 2 )
+               END IF
+               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
+     $              THEN
+                  RWORK( J ) = ZERO
+               ELSE
+                  RWORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
+     $                         ( POLES( J, 2 )+DJ )
+               END IF
+               DO 30 I = 1, J - 1
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                            ( DLAMC3( POLES( I, 2 ), DSIGJ )-
+     $                            DIFLJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   30          CONTINUE
+               DO 40 I = J + 1, K
+                  IF( ( Z( I ).EQ.ZERO ) .OR.
+     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = POLES( I, 2 )*Z( I ) /
+     $                            ( DLAMC3( POLES( I, 2 ), DSIGJP )+
+     $                            DIFRJ ) / ( POLES( I, 2 )+DJ )
+                  END IF
+   40          CONTINUE
+               RWORK( 1 ) = NEGONE
+               TEMP = DNRM2( K, RWORK, 1 )
+*
+*              Since B and BX are complex, the following call to DGEMV
+*              is performed in two steps (real and imaginary parts).
+*
+*              CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
+*    $                     B( J, 1 ), LDB )
+*
+               I = K + NRHS*2
+               DO 60 JCOL = 1, NRHS
+                  DO 50 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = DBLE( BX( JROW, JCOL ) )
+   50             CONTINUE
+   60          CONTINUE
+               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
+               I = K + NRHS*2
+               DO 80 JCOL = 1, NRHS
+                  DO 70 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = DIMAG( BX( JROW, JCOL ) )
+   70             CONTINUE
+   80          CONTINUE
+               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
+               DO 90 JCOL = 1, NRHS
+                  B( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
+     $                           RWORK( JCOL+K+NRHS ) )
+   90          CONTINUE
+               CALL ZLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
+     $                      LDB, INFO )
+  100       CONTINUE
+         END IF
+*
+*        Move the deflated rows of BX to B also.
+*
+         IF( K.LT.MAX( M, N ) )
+     $      CALL ZLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
+     $                   B( K+1, 1 ), LDB )
+      ELSE
+*
+*        Apply back the right orthogonal transformations.
+*
+*        Step (1R): apply back the new right singular vector matrix
+*        to B.
+*
+         IF( K.EQ.1 ) THEN
+            CALL ZCOPY( NRHS, B, LDB, BX, LDBX )
+         ELSE
+            DO 180 J = 1, K
+               DSIGJ = POLES( J, 2 )
+               IF( Z( J ).EQ.ZERO ) THEN
+                  RWORK( J ) = ZERO
+               ELSE
+                  RWORK( J ) = -Z( J ) / DIFL( J ) /
+     $                         ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
+               END IF
+               DO 110 I = 1, J - 1
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
+     $                            2 ) )-DIFR( I, 1 ) ) /
+     $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+  110          CONTINUE
+               DO 120 I = J + 1, K
+                  IF( Z( J ).EQ.ZERO ) THEN
+                     RWORK( I ) = ZERO
+                  ELSE
+                     RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
+     $                            2 ) )-DIFL( I ) ) /
+     $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+                  END IF
+  120          CONTINUE
+*
+*              Since B and BX are complex, the following call to DGEMV
+*              is performed in two steps (real and imaginary parts).
+*
+*              CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
+*    $                     BX( J, 1 ), LDBX )
+*
+               I = K + NRHS*2
+               DO 140 JCOL = 1, NRHS
+                  DO 130 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = DBLE( B( JROW, JCOL ) )
+  130             CONTINUE
+  140          CONTINUE
+               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
+               I = K + NRHS*2
+               DO 160 JCOL = 1, NRHS
+                  DO 150 JROW = 1, K
+                     I = I + 1
+                     RWORK( I ) = DIMAG( B( JROW, JCOL ) )
+  150             CONTINUE
+  160          CONTINUE
+               CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
+     $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
+               DO 170 JCOL = 1, NRHS
+                  BX( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
+     $                            RWORK( JCOL+K+NRHS ) )
+  170          CONTINUE
+  180       CONTINUE
+         END IF
+*
+*        Step (2R): if SQRE = 1, apply back the rotation that is
+*        related to the right null space of the subproblem.
+*
+         IF( SQRE.EQ.1 ) THEN
+            CALL ZCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
+            CALL ZDROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
+         END IF
+         IF( K.LT.MAX( M, N ) )
+     $      CALL ZLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
+     $                   LDBX )
+*
+*        Step (3R): permute rows of B.
+*
+         CALL ZCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
+         IF( SQRE.EQ.1 ) THEN
+            CALL ZCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
+         END IF
+         DO 190 I = 2, N
+            CALL ZCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
+  190    CONTINUE
+*
+*        Step (4R): apply back the Givens rotations performed.
+*
+         DO 200 I = GIVPTR, 1, -1
+            CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+     $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+     $                  -GIVNUM( I, 1 ) )
+  200    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLALS0
+*
+      END
diff --git a/SRC/zlalsa.f b/SRC/zlalsa.f
new file mode 100644
index 00000000..a1516bc3
--- /dev/null
+++ b/SRC/zlalsa.f
@@ -0,0 +1,503 @@
+      SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U,
+     $                   LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR,
+     $                   GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
+     $                   SMLSIZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+     $                   K( * ), PERM( LDGCOL, * )
+      DOUBLE PRECISION   C( * ), DIFL( LDU, * ), DIFR( LDU, * ),
+     $                   GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ),
+     $                   S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * )
+      COMPLEX*16         B( LDB, * ), BX( LDBX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLALSA is an itermediate step in solving the least squares problem
+*  by computing the SVD of the coefficient matrix in compact form (The
+*  singular vectors are computed as products of simple orthorgonal
+*  matrices.).
+*
+*  If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector
+*  matrix of an upper bidiagonal matrix to the right hand side; and if
+*  ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the
+*  right hand side. The singular vector matrices were generated in
+*  compact form by ZLALSA.
+*
+*  Arguments
+*  =========
+*
+*  ICOMPQ (input) INTEGER
+*         Specifies whether the left or the right singular vector
+*         matrix is involved.
+*         = 0: Left singular vector matrix
+*         = 1: Right singular vector matrix
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The row and column dimensions of the upper bidiagonal matrix.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B and BX. NRHS must be at least 1.
+*
+*  B      (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )
+*         On input, B contains the right hand sides of the least
+*         squares problem in rows 1 through M.
+*         On output, B contains the solution X in rows 1 through N.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,MAX( M, N ) ).
+*
+*  BX     (output) COMPLEX*16 array, dimension ( LDBX, NRHS )
+*         On exit, the result of applying the left or right singular
+*         vector matrix to B.
+*
+*  LDBX   (input) INTEGER
+*         The leading dimension of BX.
+*
+*  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
+*         On entry, U contains the left singular vector matrices of all
+*         subproblems at the bottom level.
+*
+*  LDU    (input) INTEGER, LDU = > N.
+*         The leading dimension of arrays U, VT, DIFL, DIFR,
+*         POLES, GIVNUM, and Z.
+*
+*  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
+*         On entry, VT' contains the right singular vector matrices of
+*         all subproblems at the bottom level.
+*
+*  K      (input) INTEGER array, dimension ( N ).
+*
+*  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
+*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
+*
+*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
+*         distances between singular values on the I-th level and
+*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
+*         record the normalizing factors of the right singular vectors
+*         matrices of subproblems on I-th level.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
+*         On entry, Z(1, I) contains the components of the deflation-
+*         adjusted updating row vector for subproblems on the I-th
+*         level.
+*
+*  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
+*         singular values involved in the secular equations on the I-th
+*         level.
+*
+*  GIVPTR (input) INTEGER array, dimension ( N ).
+*         On entry, GIVPTR( I ) records the number of Givens
+*         rotations performed on the I-th problem on the computation
+*         tree.
+*
+*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
+*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
+*         locations of Givens rotations performed on the I-th level on
+*         the computation tree.
+*
+*  LDGCOL (input) INTEGER, LDGCOL = > N.
+*         The leading dimension of arrays GIVCOL and PERM.
+*
+*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).
+*         On entry, PERM(*, I) records permutations done on the I-th
+*         level of the computation tree.
+*
+*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
+*         values of Givens rotations performed on the I-th level on the
+*         computation tree.
+*
+*  C      (input) DOUBLE PRECISION array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         C( I ) contains the C-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  S      (input) DOUBLE PRECISION array, dimension ( N ).
+*         On entry, if the I-th subproblem is not square,
+*         S( I ) contains the S-value of a Givens rotation related to
+*         the right null space of the I-th subproblem.
+*
+*  RWORK  (workspace) DOUBLE PRECISION array, dimension at least
+*         max ( N, (SMLSZ+1)*NRHS*3 ).
+*
+*  IWORK  (workspace) INTEGER array.
+*         The dimension must be at least 3 * 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
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, IC, IM1, INODE, J, JCOL, JIMAG, JREAL,
+     $                   JROW, LF, LL, LVL, LVL2, ND, NDB1, NDIML,
+     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQRE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLASDT, XERBLA, ZCOPY, ZLALS0
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DIMAG
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+         INFO = -1
+      ELSE IF( SMLSIZ.LT.3 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.SMLSIZ ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.N ) THEN
+         INFO = -6
+      ELSE IF( LDBX.LT.N ) THEN
+         INFO = -8
+      ELSE IF( LDU.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDGCOL.LT.N ) THEN
+         INFO = -19
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLALSA', -INFO )
+         RETURN
+      END IF
+*
+*     Book-keeping and  setting up the computation tree.
+*
+      INODE = 1
+      NDIML = INODE + N
+      NDIMR = NDIML + N
+*
+      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+     $             IWORK( NDIMR ), SMLSIZ )
+*
+*     The following code applies back the left singular vector factors.
+*     For applying back the right singular vector factors, go to 170.
+*
+      IF( ICOMPQ.EQ.1 ) THEN
+         GO TO 170
+      END IF
+*
+*     The nodes on the bottom level of the tree were solved
+*     by DLASDQ. The corresponding left and right singular vector
+*     matrices are in explicit form. First apply back the left
+*     singular vector matrices.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 130 I = NDB1, ND
+*
+*        IC : center row of each node
+*        NL : number of rows of left  subproblem
+*        NR : number of rows of right subproblem
+*        NLF: starting row of the left   subproblem
+*        NRF: starting row of the right  subproblem
+*
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLF = IC - NL
+         NRF = IC + 1
+*
+*        Since B and BX are complex, the following call to DGEMM
+*        is performed in two steps (real and imaginary parts).
+*
+*        CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+*     $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+*
+         J = NL*NRHS*2
+         DO 20 JCOL = 1, NRHS
+            DO 10 JROW = NLF, NLF + NL - 1
+               J = J + 1
+               RWORK( J ) = DBLE( B( JROW, JCOL ) )
+   10       CONTINUE
+   20    CONTINUE
+         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+     $               RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1 ), NL )
+         J = NL*NRHS*2
+         DO 40 JCOL = 1, NRHS
+            DO 30 JROW = NLF, NLF + NL - 1
+               J = J + 1
+               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+   30       CONTINUE
+   40    CONTINUE
+         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+     $               RWORK( 1+NL*NRHS*2 ), NL, ZERO, RWORK( 1+NL*NRHS ),
+     $               NL )
+         JREAL = 0
+         JIMAG = NL*NRHS
+         DO 60 JCOL = 1, NRHS
+            DO 50 JROW = NLF, NLF + NL - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+   50       CONTINUE
+   60    CONTINUE
+*
+*        Since B and BX are complex, the following call to DGEMM
+*        is performed in two steps (real and imaginary parts).
+*
+*        CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+*    $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+*
+         J = NR*NRHS*2
+         DO 80 JCOL = 1, NRHS
+            DO 70 JROW = NRF, NRF + NR - 1
+               J = J + 1
+               RWORK( J ) = DBLE( B( JROW, JCOL ) )
+   70       CONTINUE
+   80    CONTINUE
+         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+     $               RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1 ), NR )
+         J = NR*NRHS*2
+         DO 100 JCOL = 1, NRHS
+            DO 90 JROW = NRF, NRF + NR - 1
+               J = J + 1
+               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+   90       CONTINUE
+  100    CONTINUE
+         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+     $               RWORK( 1+NR*NRHS*2 ), NR, ZERO, RWORK( 1+NR*NRHS ),
+     $               NR )
+         JREAL = 0
+         JIMAG = NR*NRHS
+         DO 120 JCOL = 1, NRHS
+            DO 110 JROW = NRF, NRF + NR - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+  110       CONTINUE
+  120    CONTINUE
+*
+  130 CONTINUE
+*
+*     Next copy the rows of B that correspond to unchanged rows
+*     in the bidiagonal matrix to BX.
+*
+      DO 140 I = 1, ND
+         IC = IWORK( INODE+I-1 )
+         CALL ZCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
+  140 CONTINUE
+*
+*     Finally go through the left singular vector matrices of all
+*     the other subproblems bottom-up on the tree.
+*
+      J = 2**NLVL
+      SQRE = 0
+*
+      DO 160 LVL = NLVL, 1, -1
+         LVL2 = 2*LVL - 1
+*
+*        find the first node LF and last node LL on
+*        the current level LVL
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 150 I = LF, LL
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            J = J - 1
+            CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
+     $                   B( NLF, 1 ), LDB, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
+     $                   INFO )
+  150    CONTINUE
+  160 CONTINUE
+      GO TO 330
+*
+*     ICOMPQ = 1: applying back the right singular vector factors.
+*
+  170 CONTINUE
+*
+*     First now go through the right singular vector matrices of all
+*     the tree nodes top-down.
+*
+      J = 0
+      DO 190 LVL = 1, NLVL
+         LVL2 = 2*LVL - 1
+*
+*        Find the first node LF and last node LL on
+*        the current level LVL.
+*
+         IF( LVL.EQ.1 ) THEN
+            LF = 1
+            LL = 1
+         ELSE
+            LF = 2**( LVL-1 )
+            LL = 2*LF - 1
+         END IF
+         DO 180 I = LL, LF, -1
+            IM1 = I - 1
+            IC = IWORK( INODE+IM1 )
+            NL = IWORK( NDIML+IM1 )
+            NR = IWORK( NDIMR+IM1 )
+            NLF = IC - NL
+            NRF = IC + 1
+            IF( I.EQ.LL ) THEN
+               SQRE = 0
+            ELSE
+               SQRE = 1
+            END IF
+            J = J + 1
+            CALL ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
+     $                   BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
+     $                   GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+     $                   GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+     $                   DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+     $                   Z( NLF, LVL ), K( J ), C( J ), S( J ), RWORK,
+     $                   INFO )
+  180    CONTINUE
+  190 CONTINUE
+*
+*     The nodes on the bottom level of the tree were solved
+*     by DLASDQ. The corresponding right singular vector
+*     matrices are in explicit form. Apply them back.
+*
+      NDB1 = ( ND+1 ) / 2
+      DO 320 I = NDB1, ND
+         I1 = I - 1
+         IC = IWORK( INODE+I1 )
+         NL = IWORK( NDIML+I1 )
+         NR = IWORK( NDIMR+I1 )
+         NLP1 = NL + 1
+         IF( I.EQ.ND ) THEN
+            NRP1 = NR
+         ELSE
+            NRP1 = NR + 1
+         END IF
+         NLF = IC - NL
+         NRF = IC + 1
+*
+*        Since B and BX are complex, the following call to DGEMM is
+*        performed in two steps (real and imaginary parts).
+*
+*        CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+*    $               B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+*
+         J = NLP1*NRHS*2
+         DO 210 JCOL = 1, NRHS
+            DO 200 JROW = NLF, NLF + NLP1 - 1
+               J = J + 1
+               RWORK( J ) = DBLE( B( JROW, JCOL ) )
+  200       CONTINUE
+  210    CONTINUE
+         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+     $               RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO, RWORK( 1 ),
+     $               NLP1 )
+         J = NLP1*NRHS*2
+         DO 230 JCOL = 1, NRHS
+            DO 220 JROW = NLF, NLF + NLP1 - 1
+               J = J + 1
+               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+  220       CONTINUE
+  230    CONTINUE
+         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+     $               RWORK( 1+NLP1*NRHS*2 ), NLP1, ZERO,
+     $               RWORK( 1+NLP1*NRHS ), NLP1 )
+         JREAL = 0
+         JIMAG = NLP1*NRHS
+         DO 250 JCOL = 1, NRHS
+            DO 240 JROW = NLF, NLF + NLP1 - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+  240       CONTINUE
+  250    CONTINUE
+*
+*        Since B and BX are complex, the following call to DGEMM is
+*        performed in two steps (real and imaginary parts).
+*
+*        CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+*    $               B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+*
+         J = NRP1*NRHS*2
+         DO 270 JCOL = 1, NRHS
+            DO 260 JROW = NRF, NRF + NRP1 - 1
+               J = J + 1
+               RWORK( J ) = DBLE( B( JROW, JCOL ) )
+  260       CONTINUE
+  270    CONTINUE
+         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+     $               RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO, RWORK( 1 ),
+     $               NRP1 )
+         J = NRP1*NRHS*2
+         DO 290 JCOL = 1, NRHS
+            DO 280 JROW = NRF, NRF + NRP1 - 1
+               J = J + 1
+               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+  280       CONTINUE
+  290    CONTINUE
+         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+     $               RWORK( 1+NRP1*NRHS*2 ), NRP1, ZERO,
+     $               RWORK( 1+NRP1*NRHS ), NRP1 )
+         JREAL = 0
+         JIMAG = NRP1*NRHS
+         DO 310 JCOL = 1, NRHS
+            DO 300 JROW = NRF, NRF + NRP1 - 1
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               BX( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                            RWORK( JIMAG ) )
+  300       CONTINUE
+  310    CONTINUE
+*
+  320 CONTINUE
+*
+  330 CONTINUE
+*
+      RETURN
+*
+*     End of ZLALSA
+*
+      END
diff --git a/SRC/zlalsd.f b/SRC/zlalsd.f
new file mode 100644
index 00000000..8f01f7b2
--- /dev/null
+++ b/SRC/zlalsd.f
@@ -0,0 +1,600 @@
+      SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
+     $                   RANK, WORK, RWORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
+      COMPLEX*16         B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLALSD uses the singular value decomposition of A to solve the least
+*  squares problem of finding X to minimize the Euclidean norm of each
+*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
+*  are N-by-NRHS. The solution X overwrites B.
+*
+*  The singular values of A smaller than RCOND times the largest
+*  singular value are treated as zero in solving the least squares
+*  problem; in this case a minimum norm solution is returned.
+*  The actual singular values are returned in D in ascending order.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.
+*
+*  Arguments
+*  =========
+*
+*  UPLO   (input) CHARACTER*1
+*         = 'U': D and E define an upper bidiagonal matrix.
+*         = 'L': D and E define a  lower bidiagonal matrix.
+*
+*  SMLSIZ (input) INTEGER
+*         The maximum size of the subproblems at the bottom of the
+*         computation tree.
+*
+*  N      (input) INTEGER
+*         The dimension of the  bidiagonal matrix.  N >= 0.
+*
+*  NRHS   (input) INTEGER
+*         The number of columns of B. NRHS must be at least 1.
+*
+*  D      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On entry D contains the main diagonal of the bidiagonal
+*         matrix. On exit, if INFO = 0, D contains its singular values.
+*
+*  E      (input/output) DOUBLE PRECISION array, dimension (N-1)
+*         Contains the super-diagonal entries of the bidiagonal matrix.
+*         On exit, E has been destroyed.
+*
+*  B      (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*         On input, B contains the right hand sides of the least
+*         squares problem. On output, B contains the solution X.
+*
+*  LDB    (input) INTEGER
+*         The leading dimension of B in the calling subprogram.
+*         LDB must be at least max(1,N).
+*
+*  RCOND  (input) DOUBLE PRECISION
+*         The singular values of A less than or equal to RCOND times
+*         the largest singular value are treated as zero in solving
+*         the least squares problem. If RCOND is negative,
+*         machine precision is used instead.
+*         For example, if diag(S)*X=B were the least squares problem,
+*         where diag(S) is a diagonal matrix of singular values, the
+*         solution would be X(i) = B(i) / S(i) if S(i) is greater than
+*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
+*         RCOND*max(S).
+*
+*  RANK   (output) INTEGER
+*         The number of singular values of A greater than RCOND times
+*         the largest singular value.
+*
+*  WORK   (workspace) COMPLEX*16 array, dimension at least
+*         (N * NRHS).
+*
+*  RWORK  (workspace) DOUBLE PRECISION array, dimension at least
+*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2),
+*         where
+*         NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+*
+*  IWORK  (workspace) INTEGER array, dimension at least
+*         (3*N*NLVL + 11*N).
+*
+*  INFO   (output) INTEGER
+*         = 0:  successful exit.
+*         < 0:  if INFO = -i, the i-th argument had an illegal value.
+*         > 0:  The algorithm failed to compute an singular value while
+*               working on the submatrix lying in rows and columns
+*               INFO/(N+1) through MOD(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
+*       California at Berkeley, USA
+*     Osni Marques, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
+     $                   GIVPTR, I, ICMPQ1, ICMPQ2, IRWB, IRWIB, IRWRB,
+     $                   IRWU, IRWVT, IRWWRK, IWK, J, JCOL, JIMAG,
+     $                   JREAL, JROW, K, NLVL, NM1, NRWORK, NSIZE, NSUB,
+     $                   PERM, POLES, S, SIZEI, SMLSZP, SQRE, ST, ST1,
+     $                   U, VT, Z
+      DOUBLE PRECISION   CS, EPS, ORGNRM, RCND, R, SN, TOL
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           IDAMAX, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLARTG, DLASCL, DLASDA, DLASDQ, DLASET,
+     $                   DLASRT, XERBLA, ZCOPY, ZDROT, ZLACPY, ZLALSA,
+     $                   ZLASCL, ZLASET
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, LOG, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLALSD', -INFO )
+         RETURN
+      END IF
+*
+      EPS = DLAMCH( 'Epsilon' )
+*
+*     Set up the tolerance.
+*
+      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
+         RCND = EPS
+      ELSE
+         RCND = RCOND
+      END IF
+*
+      RANK = 0
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         IF( D( 1 ).EQ.ZERO ) THEN
+            CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B, LDB )
+         ELSE
+            RANK = 1
+            CALL ZLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
+            D( 1 ) = ABS( D( 1 ) )
+         END IF
+         RETURN
+      END IF
+*
+*     Rotate the matrix if it is lower bidiagonal.
+*
+      IF( UPLO.EQ.'L' ) THEN
+         DO 10 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            IF( NRHS.EQ.1 ) THEN
+               CALL ZDROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
+            ELSE
+               RWORK( I*2-1 ) = CS
+               RWORK( I*2 ) = SN
+            END IF
+   10    CONTINUE
+         IF( NRHS.GT.1 ) THEN
+            DO 30 I = 1, NRHS
+               DO 20 J = 1, N - 1
+                  CS = RWORK( J*2-1 )
+                  SN = RWORK( J*2 )
+                  CALL ZDROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
+   20          CONTINUE
+   30       CONTINUE
+         END IF
+      END IF
+*
+*     Scale.
+*
+      NM1 = N - 1
+      ORGNRM = DLANST( 'M', N, D, E )
+      IF( ORGNRM.EQ.ZERO ) THEN
+         CALL ZLASET( 'A', N, NRHS, CZERO, CZERO, B, LDB )
+         RETURN
+      END IF
+*
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
+*
+*     If N is smaller than the minimum divide size SMLSIZ, then solve
+*     the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+         IRWU = 1
+         IRWVT = IRWU + N*N
+         IRWWRK = IRWVT + N*N
+         IRWRB = IRWWRK
+         IRWIB = IRWRB + N*NRHS
+         IRWB = IRWIB + N*NRHS
+         CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWU ), N )
+         CALL DLASET( 'A', N, N, ZERO, ONE, RWORK( IRWVT ), N )
+         CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, RWORK( IRWVT ), N,
+     $                RWORK( IRWU ), N, RWORK( IRWWRK ), 1,
+     $                RWORK( IRWWRK ), INFO )
+         IF( INFO.NE.0 ) THEN
+            RETURN
+         END IF
+*
+*        In the real version, B is passed to DLASDQ and multiplied
+*        internally by Q'. Here B is complex and that product is
+*        computed below in two steps (real and imaginary parts).
+*
+         J = IRWB - 1
+         DO 50 JCOL = 1, NRHS
+            DO 40 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = DBLE( B( JROW, JCOL ) )
+   40       CONTINUE
+   50    CONTINUE
+         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
+         J = IRWB - 1
+         DO 70 JCOL = 1, NRHS
+            DO 60 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+   60       CONTINUE
+   70    CONTINUE
+         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWU ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
+         JREAL = IRWRB - 1
+         JIMAG = IRWIB - 1
+         DO 90 JCOL = 1, NRHS
+            DO 80 JROW = 1, N
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                           RWORK( JIMAG ) )
+   80       CONTINUE
+   90    CONTINUE
+*
+         TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
+         DO 100 I = 1, N
+            IF( D( I ).LE.TOL ) THEN
+               CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, B( I, 1 ), LDB )
+            ELSE
+               CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
+     $                      LDB, INFO )
+               RANK = RANK + 1
+            END IF
+  100    CONTINUE
+*
+*        Since B is complex, the following call to DGEMM is performed
+*        in two steps (real and imaginary parts). That is for V * B
+*        (in the real version of the code V' is stored in WORK).
+*
+*        CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
+*    $               WORK( NWORK ), N )
+*
+         J = IRWB - 1
+         DO 120 JCOL = 1, NRHS
+            DO 110 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = DBLE( B( JROW, JCOL ) )
+  110       CONTINUE
+  120    CONTINUE
+         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWRB ), N )
+         J = IRWB - 1
+         DO 140 JCOL = 1, NRHS
+            DO 130 JROW = 1, N
+               J = J + 1
+               RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+  130       CONTINUE
+  140    CONTINUE
+         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, RWORK( IRWVT ), N,
+     $               RWORK( IRWB ), N, ZERO, RWORK( IRWIB ), N )
+         JREAL = IRWRB - 1
+         JIMAG = IRWIB - 1
+         DO 160 JCOL = 1, NRHS
+            DO 150 JROW = 1, N
+               JREAL = JREAL + 1
+               JIMAG = JIMAG + 1
+               B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                           RWORK( JIMAG ) )
+  150       CONTINUE
+  160    CONTINUE
+*
+*        Unscale.
+*
+         CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+         CALL DLASRT( 'D', N, D, INFO )
+         CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+         RETURN
+      END IF
+*
+*     Book-keeping and setting up some constants.
+*
+      NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+*
+      SMLSZP = SMLSIZ + 1
+*
+      U = 1
+      VT = 1 + SMLSIZ*N
+      DIFL = VT + SMLSZP*N
+      DIFR = DIFL + NLVL*N
+      Z = DIFR + NLVL*N*2
+      C = Z + NLVL*N
+      S = C + N
+      POLES = S + N
+      GIVNUM = POLES + 2*NLVL*N
+      NRWORK = GIVNUM + 2*NLVL*N
+      BX = 1
+*
+      IRWRB = NRWORK
+      IRWIB = IRWRB + SMLSIZ*NRHS
+      IRWB = IRWIB + SMLSIZ*NRHS
+*
+      SIZEI = 1 + N
+      K = SIZEI + N
+      GIVPTR = K + N
+      PERM = GIVPTR + N
+      GIVCOL = PERM + NLVL*N
+      IWK = GIVCOL + NLVL*N*2
+*
+      ST = 1
+      SQRE = 0
+      ICMPQ1 = 1
+      ICMPQ2 = 0
+      NSUB = 0
+*
+      DO 170 I = 1, N
+         IF( ABS( D( I ) ).LT.EPS ) THEN
+            D( I ) = SIGN( EPS, D( I ) )
+         END IF
+  170 CONTINUE
+*
+      DO 240 I = 1, NM1
+         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+            NSUB = NSUB + 1
+            IWORK( NSUB ) = ST
+*
+*           Subproblem found. First determine its size and then
+*           apply divide and conquer on it.
+*
+            IF( I.LT.NM1 ) THEN
+*
+*              A subproblem with E(I) small for I < NM1.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+*              A subproblem with E(NM1) not too small but I = NM1.
+*
+               NSIZE = N - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+            ELSE
+*
+*              A subproblem with E(NM1) small. This implies an
+*              1-by-1 subproblem at D(N), which is not solved
+*              explicitly.
+*
+               NSIZE = I - ST + 1
+               IWORK( SIZEI+NSUB-1 ) = NSIZE
+               NSUB = NSUB + 1
+               IWORK( NSUB ) = N
+               IWORK( SIZEI+NSUB-1 ) = 1
+               CALL ZCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
+            END IF
+            ST1 = ST - 1
+            IF( NSIZE.EQ.1 ) THEN
+*
+*              This is a 1-by-1 subproblem and is not solved
+*              explicitly.
+*
+               CALL ZCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
+            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+*              This is a small subproblem and is solved by DLASDQ.
+*
+               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+     $                      RWORK( VT+ST1 ), N )
+               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+     $                      RWORK( U+ST1 ), N )
+               CALL DLASDQ( 'U', 0, NSIZE, NSIZE, NSIZE, 0, D( ST ),
+     $                      E( ST ), RWORK( VT+ST1 ), N, RWORK( U+ST1 ),
+     $                      N, RWORK( NRWORK ), 1, RWORK( NRWORK ),
+     $                      INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+*
+*              In the real version, B is passed to DLASDQ and multiplied
+*              internally by Q'. Here B is complex and that product is
+*              computed below in two steps (real and imaginary parts).
+*
+               J = IRWB - 1
+               DO 190 JCOL = 1, NRHS
+                  DO 180 JROW = ST, ST + NSIZE - 1
+                     J = J + 1
+                     RWORK( J ) = DBLE( B( JROW, JCOL ) )
+  180             CONTINUE
+  190          CONTINUE
+               CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                     RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
+     $                     ZERO, RWORK( IRWRB ), NSIZE )
+               J = IRWB - 1
+               DO 210 JCOL = 1, NRHS
+                  DO 200 JROW = ST, ST + NSIZE - 1
+                     J = J + 1
+                     RWORK( J ) = DIMAG( B( JROW, JCOL ) )
+  200             CONTINUE
+  210          CONTINUE
+               CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                     RWORK( U+ST1 ), N, RWORK( IRWB ), NSIZE,
+     $                     ZERO, RWORK( IRWIB ), NSIZE )
+               JREAL = IRWRB - 1
+               JIMAG = IRWIB - 1
+               DO 230 JCOL = 1, NRHS
+                  DO 220 JROW = ST, ST + NSIZE - 1
+                     JREAL = JREAL + 1
+                     JIMAG = JIMAG + 1
+                     B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                                 RWORK( JIMAG ) )
+  220             CONTINUE
+  230          CONTINUE
+*
+               CALL ZLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
+     $                      WORK( BX+ST1 ), N )
+            ELSE
+*
+*              A large problem. Solve it using divide and conquer.
+*
+               CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
+     $                      E( ST ), RWORK( U+ST1 ), N, RWORK( VT+ST1 ),
+     $                      IWORK( K+ST1 ), RWORK( DIFL+ST1 ),
+     $                      RWORK( DIFR+ST1 ), RWORK( Z+ST1 ),
+     $                      RWORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
+     $                      IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
+     $                      RWORK( GIVNUM+ST1 ), RWORK( C+ST1 ),
+     $                      RWORK( S+ST1 ), RWORK( NRWORK ),
+     $                      IWORK( IWK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+               BXST = BX + ST1
+               CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
+     $                      LDB, WORK( BXST ), N, RWORK( U+ST1 ), N,
+     $                      RWORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                      RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
+     $                      RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
+     $                      IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                      IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
+     $                      RWORK( C+ST1 ), RWORK( S+ST1 ),
+     $                      RWORK( NRWORK ), IWORK( IWK ), INFO )
+               IF( INFO.NE.0 ) THEN
+                  RETURN
+               END IF
+            END IF
+            ST = I + 1
+         END IF
+  240 CONTINUE
+*
+*     Apply the singular values and treat the tiny ones as zero.
+*
+      TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
+*
+      DO 250 I = 1, N
+*
+*        Some of the elements in D can be negative because 1-by-1
+*        subproblems were not solved explicitly.
+*
+         IF( ABS( D( I ) ).LE.TOL ) THEN
+            CALL ZLASET( 'A', 1, NRHS, CZERO, CZERO, WORK( BX+I-1 ), N )
+         ELSE
+            RANK = RANK + 1
+            CALL ZLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
+     $                   WORK( BX+I-1 ), N, INFO )
+         END IF
+         D( I ) = ABS( D( I ) )
+  250 CONTINUE
+*
+*     Now apply back the right singular vectors.
+*
+      ICMPQ2 = 1
+      DO 320 I = 1, NSUB
+         ST = IWORK( I )
+         ST1 = ST - 1
+         NSIZE = IWORK( SIZEI+I-1 )
+         BXST = BX + ST1
+         IF( NSIZE.EQ.1 ) THEN
+            CALL ZCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
+         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+*           Since B and BX are complex, the following call to DGEMM
+*           is performed in two steps (real and imaginary parts).
+*
+*           CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+*    $                  RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO,
+*    $                  B( ST, 1 ), LDB )
+*
+            J = BXST - N - 1
+            JREAL = IRWB - 1
+            DO 270 JCOL = 1, NRHS
+               J = J + N
+               DO 260 JROW = 1, NSIZE
+                  JREAL = JREAL + 1
+                  RWORK( JREAL ) = DBLE( WORK( J+JROW ) )
+  260          CONTINUE
+  270       CONTINUE
+            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                  RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
+     $                  RWORK( IRWRB ), NSIZE )
+            J = BXST - N - 1
+            JIMAG = IRWB - 1
+            DO 290 JCOL = 1, NRHS
+               J = J + N
+               DO 280 JROW = 1, NSIZE
+                  JIMAG = JIMAG + 1
+                  RWORK( JIMAG ) = DIMAG( WORK( J+JROW ) )
+  280          CONTINUE
+  290       CONTINUE
+            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+     $                  RWORK( VT+ST1 ), N, RWORK( IRWB ), NSIZE, ZERO,
+     $                  RWORK( IRWIB ), NSIZE )
+            JREAL = IRWRB - 1
+            JIMAG = IRWIB - 1
+            DO 310 JCOL = 1, NRHS
+               DO 300 JROW = ST, ST + NSIZE - 1
+                  JREAL = JREAL + 1
+                  JIMAG = JIMAG + 1
+                  B( JROW, JCOL ) = DCMPLX( RWORK( JREAL ),
+     $                              RWORK( JIMAG ) )
+  300          CONTINUE
+  310       CONTINUE
+         ELSE
+            CALL ZLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
+     $                   B( ST, 1 ), LDB, RWORK( U+ST1 ), N,
+     $                   RWORK( VT+ST1 ), IWORK( K+ST1 ),
+     $                   RWORK( DIFL+ST1 ), RWORK( DIFR+ST1 ),
+     $                   RWORK( Z+ST1 ), RWORK( POLES+ST1 ),
+     $                   IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+     $                   IWORK( PERM+ST1 ), RWORK( GIVNUM+ST1 ),
+     $                   RWORK( C+ST1 ), RWORK( S+ST1 ),
+     $                   RWORK( NRWORK ), IWORK( IWK ), INFO )
+            IF( INFO.NE.0 ) THEN
+               RETURN
+            END IF
+         END IF
+  320 CONTINUE
+*
+*     Unscale and sort the singular values.
+*
+      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+      CALL DLASRT( 'D', N, D, INFO )
+      CALL ZLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+      RETURN
+*
+*     End of ZLALSD
+*
+      END
diff --git a/SRC/zlangb.f b/SRC/zlangb.f
new file mode 100644
index 00000000..99dd3beb
--- /dev/null
+++ b/SRC/zlangb.f
@@ -0,0 +1,154 @@
+      DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB,
+     $                 WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            KL, KU, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANGB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  ZLANGB returns the value
+*
+*     ZLANGB = ( 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 ZLANGB as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANGB is
+*          set to zero.
+*
+*  KL      (input) INTEGER
+*          The number of sub-diagonals of the matrix A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of super-diagonals of the matrix A.  KU >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
+*          column of A is stored in the j-th column of the array AB as
+*          follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KL+KU+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, K, L
+      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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               VALUE = MAX( VALUE, ABS( AB( 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 = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+               SUM = SUM + ABS( AB( 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
+            K = KU + 1 - J
+            DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
+               WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, N
+            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
+            L = MAX( 1, J-KU )
+            K = KU + 1 - J + L
+            CALL ZLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANGB = VALUE
+      RETURN
+*
+*     End of ZLANGB
+*
+      END
diff --git a/SRC/zlange.f b/SRC/zlange.f
new file mode 100644
index 00000000..36cecbdc
--- /dev/null
+++ b/SRC/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/zlangt.f b/SRC/zlangt.f
new file mode 100644
index 00000000..d2a25db5
--- /dev/null
+++ b/SRC/zlangt.f
@@ -0,0 +1,141 @@
+      DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )
+*
+*  -- 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 ..
+      COMPLEX*16         D( * ), DL( * ), DU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANGT  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 tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  ZLANGT returns the value
+*
+*     ZLANGT = ( 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 ZLANGT as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANGT is
+*          set to zero.
+*
+*  DL      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) sub-diagonal elements of A.
+*
+*  D       (input) COMPLEX*16 array, dimension (N)
+*          The diagonal elements of A.
+*
+*  DU      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) 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           ZLASSQ
+*     ..
+*     .. 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( DL( I ) ) )
+            ANORM = MAX( ANORM, ABS( D( I ) ) )
+            ANORM = MAX( ANORM, ABS( DU( I ) ) )
+   10    CONTINUE
+      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
+*
+*        Find norm1(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
+     $              ABS( D( N ) )+ABS( DU( N-1 ) ) )
+            DO 20 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
+     $                 ABS( DU( I-1 ) ) )
+   20       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
+     $              ABS( D( N ) )+ABS( DL( N-1 ) ) )
+            DO 30 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
+     $                 ABS( DL( I-1 ) ) )
+   30       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         CALL ZLASSQ( N, D, 1, SCALE, SUM )
+         IF( N.GT.1 ) THEN
+            CALL ZLASSQ( N-1, DL, 1, SCALE, SUM )
+            CALL ZLASSQ( N-1, DU, 1, SCALE, SUM )
+         END IF
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANGT = ANORM
+      RETURN
+*
+*     End of ZLANGT
+*
+      END
diff --git a/SRC/zlanhb.f b/SRC/zlanhb.f
new file mode 100644
index 00000000..1fd88397
--- /dev/null
+++ b/SRC/zlanhb.f
@@ -0,0 +1,201 @@
+      DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB,
+     $                 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANHB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n hermitian band matrix A,  with k super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  ZLANHB returns the value
+*
+*     ZLANHB = ( 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 ZLANHB as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          band matrix A is supplied.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals or sub-diagonals of the
+*          band matrix A.  K >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangle of the hermitian band matrix A,
+*          stored in the first K+1 rows of AB.  The j-th column of A is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*          Note that the imaginary parts of the diagonal elements need
+*          not be set and are assumed to be zero.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+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, L
+      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = MAX( K+2-J, 1 ), K
+                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10          CONTINUE
+               VALUE = MAX( VALUE, ABS( DBLE( AB( K+1, J ) ) ) )
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               VALUE = MAX( VALUE, ABS( DBLE( AB( 1, J ) ) ) )
+               DO 30 I = 2, MIN( N+1-J, K+1 )
+                  VALUE = MAX( VALUE, ABS( AB( 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
+               L = K + 1 - J
+               DO 50 I = MAX( 1, J-K ), J - 1
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( DBLE( AB( K+1, 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( AB( 1, J ) ) )
+               L = 1 - J
+               DO 90 I = J + 1, MIN( N, J+K )
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               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( K.GT.0 ) THEN
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 110 J = 2, N
+                  CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  110          CONTINUE
+               L = K + 1
+            ELSE
+               DO 120 J = 1, N - 1
+                  CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                         SUM )
+  120          CONTINUE
+               L = 1
+            END IF
+            SUM = 2*SUM
+         ELSE
+            L = 1
+         END IF
+         DO 130 J = 1, N
+            IF( DBLE( AB( L, J ) ).NE.ZERO ) THEN
+               ABSA = ABS( DBLE( AB( L, J ) ) )
+               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
+*
+      ZLANHB = VALUE
+      RETURN
+*
+*     End of ZLANHB
+*
+      END
diff --git a/SRC/zlanhe.f b/SRC/zlanhe.f
new file mode 100644
index 00000000..86e57fcd
--- /dev/null
+++ b/SRC/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/zlanhp.f b/SRC/zlanhp.f
new file mode 100644
index 00000000..c0ff3b94
--- /dev/null
+++ b/SRC/zlanhp.f
@@ -0,0 +1,201 @@
+      DOUBLE PRECISION FUNCTION ZLANHP( 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   WORK( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANHP  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,  supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  ZLANHP returns the value
+*
+*     ZLANHP = ( 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 ZLANHP as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          hermitian 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, ZLANHP is
+*          set to zero.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the hermitian matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          Note that the  imaginary parts of the diagonal elements need
+*          not be set and are assumed to be zero.
+*
+*  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 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
+            K = 0
+            DO 20 J = 1, N
+               DO 10 I = K + 1, K + J - 1
+                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10          CONTINUE
+               K = K + J
+               VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) )
+   20       CONTINUE
+         ELSE
+            K = 1
+            DO 40 J = 1, N
+               VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) )
+               DO 30 I = K + 1, 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 hermitian).
+*
+         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( DBLE( 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( DBLE( 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 ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+               K = K + J
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL ZLASSQ( 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( DBLE( AP( K ) ).NE.ZERO ) THEN
+               ABSA = ABS( DBLE( 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
+*
+      ZLANHP = VALUE
+      RETURN
+*
+*     End of ZLANHP
+*
+      END
diff --git a/SRC/zlanhs.f b/SRC/zlanhs.f
new file mode 100644
index 00000000..d7b187a5
--- /dev/null
+++ b/SRC/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/zlanht.f b/SRC/zlanht.f
new file mode 100644
index 00000000..3cccfdf0
--- /dev/null
+++ b/SRC/zlanht.f
@@ -0,0 +1,125 @@
+      DOUBLE PRECISION FUNCTION ZLANHT( 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( * )
+      COMPLEX*16         E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANHT  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 tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  ZLANHT returns the value
+*
+*     ZLANHT = ( 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 ZLANHT as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHT is
+*          set to zero.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of A.
+*
+*  E       (input) COMPLEX*16 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, ZLASSQ
+*     ..
+*     .. 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 ZLASSQ( N-1, E, 1, SCALE, SUM )
+            SUM = 2*SUM
+         END IF
+         CALL DLASSQ( N, D, 1, SCALE, SUM )
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANHT = ANORM
+      RETURN
+*
+*     End of ZLANHT
+*
+      END
diff --git a/SRC/zlansb.f b/SRC/zlansb.f
new file mode 100644
index 00000000..944c1087
--- /dev/null
+++ b/SRC/zlansb.f
@@ -0,0 +1,187 @@
+      DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB,
+     $                 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANSB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n symmetric band matrix A,  with k super-diagonals.
+*
+*  Description
+*  ===========
+*
+*  ZLANSB returns the value
+*
+*     ZLANSB = ( 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 ZLANSB as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          band matrix A is supplied.
+*          = 'U':  Upper triangular part is supplied
+*          = 'L':  Lower triangular part is supplied
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANSB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals or sub-diagonals of the
+*          band matrix A.  K >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangle of the symmetric band matrix A,
+*          stored in the first K+1 rows of AB.  The j-th column of A is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+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, L
+      DOUBLE PRECISION   ABSA, 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
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = MAX( K+2-J, 1 ), K + 1
+                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               DO 30 I = 1, MIN( N+1-J, K+1 )
+                  VALUE = MAX( VALUE, ABS( AB( 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
+               L = K + 1 - J
+               DO 50 I = MAX( 1, J-K ), J - 1
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( AB( K+1, J ) )
+   60       CONTINUE
+            DO 70 I = 1, N
+               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( AB( 1, J ) )
+               L = 1 - J
+               DO 90 I = J + 1, MIN( N, J+K )
+                  ABSA = ABS( AB( L+I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               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( K.GT.0 ) THEN
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 110 J = 2, N
+                  CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  110          CONTINUE
+               L = K + 1
+            ELSE
+               DO 120 J = 1, N - 1
+                  CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                         SUM )
+  120          CONTINUE
+               L = 1
+            END IF
+            SUM = 2*SUM
+         ELSE
+            L = 1
+         END IF
+         CALL ZLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANSB = VALUE
+      RETURN
+*
+*     End of ZLANSB
+*
+      END
diff --git a/SRC/zlansp.f b/SRC/zlansp.f
new file mode 100644
index 00000000..bdbcbcda
--- /dev/null
+++ b/SRC/zlansp.f
@@ -0,0 +1,206 @@
+      DOUBLE PRECISION FUNCTION ZLANSP( 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   WORK( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANSP  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 symmetric matrix A,  supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  ZLANSP returns the value
+*
+*     ZLANSP = ( 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 ZLANSP 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, ZLANSP is
+*          set to zero.
+*
+*  AP      (input) COMPLEX*16 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 Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, 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 ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+               K = K + J
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL ZLASSQ( 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( DBLE( AP( K ) ).NE.ZERO ) THEN
+               ABSA = ABS( DBLE( 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( DIMAG( AP( K ) ).NE.ZERO ) THEN
+               ABSA = ABS( DIMAG( 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
+*
+      ZLANSP = VALUE
+      RETURN
+*
+*     End of ZLANSP
+*
+      END
diff --git a/SRC/zlansy.f b/SRC/zlansy.f
new file mode 100644
index 00000000..aaf4619a
--- /dev/null
+++ b/SRC/zlansy.f
@@ -0,0 +1,174 @@
+      DOUBLE PRECISION FUNCTION ZLANSY( 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
+*  =======
+*
+*  ZLANSY  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 symmetric matrix A.
+*
+*  Description
+*  ===========
+*
+*  ZLANSY returns the value
+*
+*     ZLANSY = ( 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 ZLANSY 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, ZLANSY is
+*          set to zero.
+*
+*  A       (input) COMPLEX*16 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 Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. 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 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
+         CALL ZLASSQ( N, A, LDA+1, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANSY = VALUE
+      RETURN
+*
+*     End of ZLANSY
+*
+      END
diff --git a/SRC/zlantb.f b/SRC/zlantb.f
new file mode 100644
index 00000000..52488b0a
--- /dev/null
+++ b/SRC/zlantb.f
@@ -0,0 +1,285 @@
+      DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB,
+     $                 LDAB, 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            K, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANTB  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the element of  largest absolute value  of an
+*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.
+*
+*  Description
+*  ===========
+*
+*  ZLANTB returns the value
+*
+*     ZLANTB = ( 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 ZLANTB as described
+*          above.
+*
+*  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.  When N = 0, ZLANTB is
+*          set to zero.
+*
+*  K       (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.
+*          K >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first k+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
+*          Note that when DIAG = 'U', the elements of the array AB
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= K+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 ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, L
+      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))).
+*
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = MAX( K+2-J, 1 ), K
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = 2, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   30             CONTINUE
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = MAX( K+2-J, 1 ), K + 1
+                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = 1, MIN( N+1-J, K+1 )
+                     VALUE = MAX( VALUE, ABS( AB( 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 ) THEN
+                  SUM = ONE
+                  DO 90 I = MAX( K+2-J, 1 ), K
+                     SUM = SUM + ABS( AB( I, J ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = MAX( K+2-J, 1 ), K + 1
+                     SUM = SUM + ABS( AB( I, J ) )
+  100             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = 2, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = 1, MIN( N+1-J, K+1 )
+                     SUM = SUM + ABS( AB( I, J ) )
+  130             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  L = K + 1 - J
+                  DO 160 I = MAX( 1, J-K ), J - 1
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  160             CONTINUE
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  L = K + 1 - J
+                  DO 190 I = MAX( 1, J-K ), J
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  L = 1 - J
+                  DO 220 I = J + 1, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  L = 1 - J
+                  DO 250 I = J, MIN( N, J+K )
+                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 280 J = 2, N
+                     CALL ZLASSQ( MIN( J-1, K ),
+     $                            AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
+     $                            SUM )
+  280             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 290 J = 1, N
+                  CALL ZLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
+     $                         1, SCALE, SUM )
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               IF( K.GT.0 ) THEN
+                  DO 300 J = 1, N - 1
+                     CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+     $                            SUM )
+  300             CONTINUE
+               END IF
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 310 J = 1, N
+                  CALL ZLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANTB = VALUE
+      RETURN
+*
+*     End of ZLANTB
+*
+      END
diff --git a/SRC/zlantp.f b/SRC/zlantp.f
new file mode 100644
index 00000000..628c406c
--- /dev/null
+++ b/SRC/zlantp.f
@@ -0,0 +1,286 @@
+      DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, 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            N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANTP  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  triangular matrix A, supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  ZLANTP returns the value
+*
+*     ZLANTP = ( 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 ZLANTP as described
+*          above.
+*
+*  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.  When N = 0, ZLANTP is
+*          set to zero.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          Note that when DIAG = 'U', the elements of the array AP
+*          corresponding to the diagonal elements of the matrix A are
+*          not referenced, but are assumed to be one.
+*
+*  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 ..
+      LOGICAL            UDIAG
+      INTEGER            I, J, K
+      DOUBLE PRECISION   SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. 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))).
+*
+         K = 1
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = K, K + J - 2
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10             CONTINUE
+                  K = K + J
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = K + 1, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   30             CONTINUE
+                  K = K + N - J + 1
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = K, K + J - 1
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   50             CONTINUE
+                  K = K + J
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = K, K + N - J
+                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   70             CONTINUE
+                  K = K + N - J + 1
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         K = 1
+         UDIAG = LSAME( DIAG, 'U' )
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 90 I = K, K + J - 2
+                     SUM = SUM + ABS( AP( I ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = K, K + J - 1
+                     SUM = SUM + ABS( AP( I ) )
+  100             CONTINUE
+               END IF
+               K = K + J
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = K + 1, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = K, K + N - J
+                     SUM = SUM + ABS( AP( I ) )
+  130             CONTINUE
+               END IF
+               K = K + N - J + 1
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         K = 1
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, N
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  DO 160 I = 1, J - 1
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  160             CONTINUE
+                  K = K + 1
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, N
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  DO 190 I = 1, J
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 230 J = 1, N
+                  K = K + 1
+                  DO 220 I = J + 1, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  220             CONTINUE
+  230          CONTINUE
+            ELSE
+               DO 240 I = 1, N
+                  WORK( I ) = ZERO
+  240          CONTINUE
+               DO 260 J = 1, N
+                  DO 250 I = J, N
+                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
+                     K = K + 1
+  250             CONTINUE
+  260          CONTINUE
+            END IF
+         END IF
+         VALUE = ZERO
+         DO 270 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+  270    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 280 J = 2, N
+                  CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  280          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 290 J = 1, N
+                  CALL ZLASSQ( J, AP( K ), 1, SCALE, SUM )
+                  K = K + J
+  290          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = N
+               K = 2
+               DO 300 J = 1, N - 1
+                  CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  300          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               K = 1
+               DO 310 J = 1, N
+                  CALL ZLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
+                  K = K + N - J + 1
+  310          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANTP = VALUE
+      RETURN
+*
+*     End of ZLANTP
+*
+      END
diff --git a/SRC/zlantr.f b/SRC/zlantr.f
new file mode 100644
index 00000000..f2f37ca4
--- /dev/null
+++ b/SRC/zlantr.f
@@ -0,0 +1,277 @@
+      DOUBLE PRECISION FUNCTION ZLANTR( 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   WORK( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANTR  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
+*  ===========
+*
+*  ZLANTR returns the value
+*
+*     ZLANTR = ( 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 ZLANTR 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, ZLANTR 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, ZLANTR is set to zero.
+*
+*  A       (input) COMPLEX*16 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 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))).
+*
+         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 ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
+  290          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 300 J = 1, N
+                  CALL ZLASSQ( 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 ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 320 J = 1, N
+                  CALL ZLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
+  320          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANTR = VALUE
+      RETURN
+*
+*     End of ZLANTR
+*
+      END
diff --git a/SRC/zlapll.f b/SRC/zlapll.f
new file mode 100644
index 00000000..b55bd912
--- /dev/null
+++ b/SRC/zlapll.f
@@ -0,0 +1,103 @@
+      SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN )
+*
+*  -- 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   SSMIN
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Given two column vectors X and Y, let
+*
+*                       A = ( X Y ).
+*
+*  The subroutine first computes the QR factorization of A = Q*R,
+*  and then computes the SVD of the 2-by-2 upper triangular matrix R.
+*  The smaller singular value of R is returned in SSMIN, which is used
+*  as the measurement of the linear dependency of the vectors X and Y.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The length of the vectors X and Y.
+*
+*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)
+*          On entry, X contains the N-vector X.
+*          On exit, X is overwritten.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive elements of X. INCX > 0.
+*
+*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)
+*          On entry, Y contains the N-vector Y.
+*          On exit, Y is overwritten.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive elements of Y. INCY > 0.
+*
+*  SSMIN   (output) DOUBLE PRECISION
+*          The smallest singular value of the N-by-2 matrix A = ( X Y ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   SSMAX
+      COMPLEX*16         A11, A12, A22, C, TAU
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCONJG
+*     ..
+*     .. External Functions ..
+      COMPLEX*16         ZDOTC
+      EXTERNAL           ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAS2, ZAXPY, ZLARFG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         SSMIN = ZERO
+         RETURN
+      END IF
+*
+*     Compute the QR factorization of the N-by-2 matrix ( X Y )
+*
+      CALL ZLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
+      A11 = X( 1 )
+      X( 1 ) = CONE
+*
+      C = -DCONJG( TAU )*ZDOTC( N, X, INCX, Y, INCY )
+      CALL ZAXPY( N, C, X, INCX, Y, INCY )
+*
+      CALL ZLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
+*
+      A12 = Y( 1 )
+      A22 = Y( 1+INCY )
+*
+*     Compute the SVD of 2-by-2 Upper triangular matrix.
+*
+      CALL DLAS2( ABS( A11 ), ABS( A12 ), ABS( A22 ), SSMIN, SSMAX )
+*
+      RETURN
+*
+*     End of ZLAPLL
+*
+      END
diff --git a/SRC/zlapmt.f b/SRC/zlapmt.f
new file mode 100644
index 00000000..ee159ed0
--- /dev/null
+++ b/SRC/zlapmt.f
@@ -0,0 +1,136 @@
+      SUBROUTINE ZLAPMT( 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( * )
+      COMPLEX*16         X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAPMT 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) COMPLEX*16 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
+      COMPLEX*16         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 ZLAPMT
+*
+      END
diff --git a/SRC/zlaqgb.f b/SRC/zlaqgb.f
new file mode 100644
index 00000000..9c0afcda
--- /dev/null
+++ b/SRC/zlaqgb.f
@@ -0,0 +1,169 @@
+      SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, 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            KL, KU, LDAB, M, N
+      DOUBLE PRECISION   AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), R( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQGB equilibrates a general M by N band matrix A with KL
+*  subdiagonals and KU superdiagonals using the row and scaling factors
+*  in the vectors R and C.
+*
+*  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.
+*
+*  KL      (input) INTEGER
+*          The number of subdiagonals within the band of A.  KL >= 0.
+*
+*  KU      (input) INTEGER
+*          The number of superdiagonals within the band of A.  KU >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+*          The j-th column of A is stored in the j-th column of the
+*          array AB as follows:
+*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+*          On exit, the equilibrated matrix, in the same storage format
+*          as A.  See EQUED for the form of the equilibrated matrix.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDA >= KL+KU+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
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+     $     THEN
+*
+*        No row scaling
+*
+         IF( COLCND.GE.THRESH ) THEN
+*
+*           No column scaling
+*
+            EQUED = 'N'
+         ELSE
+*
+*           Column scaling
+*
+            DO 20 J = 1, N
+               CJ = C( J )
+               DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
+                  AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+            EQUED = 'C'
+         END IF
+      ELSE IF( COLCND.GE.THRESH ) THEN
+*
+*        Row scaling, no column scaling
+*
+         DO 40 J = 1, N
+            DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
+   30       CONTINUE
+   40    CONTINUE
+         EQUED = 'R'
+      ELSE
+*
+*        Row and column scaling
+*
+         DO 60 J = 1, N
+            CJ = C( J )
+            DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
+               AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
+   50       CONTINUE
+   60    CONTINUE
+         EQUED = 'B'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQGB
+*
+      END
diff --git a/SRC/zlaqge.f b/SRC/zlaqge.f
new file mode 100644
index 00000000..0e677146
--- /dev/null
+++ b/SRC/zlaqge.f
@@ -0,0 +1,155 @@
+      SUBROUTINE ZLAQGE( 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   C( * ), R( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQGE 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) COMPLEX*16 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 ZLAQGE
+*
+      END
diff --git a/SRC/zlaqhb.f b/SRC/zlaqhb.f
new file mode 100644
index 00000000..77c6a83e
--- /dev/null
+++ b/SRC/zlaqhb.f
@@ -0,0 +1,151 @@
+      SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            KD, LDAB, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQHB equilibrates a symmetric band matrix A using the scaling
+*  factors in the vector S.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored in band format.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = MAX( 1, J-KD ), J - 1
+                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+   10          CONTINUE
+               AB( KD+1, J ) = CJ*CJ*DBLE( AB( KD+1, J ) )
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               AB( 1, J ) = CJ*CJ*DBLE( AB( 1, J ) )
+               DO 30 I = J + 1, MIN( N, J+KD )
+                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQHB
+*
+      END
diff --git a/SRC/zlaqhe.f b/SRC/zlaqhe.f
new file mode 100644
index 00000000..c508032b
--- /dev/null
+++ b/SRC/zlaqhe.f
@@ -0,0 +1,147 @@
+      SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            LDA, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQHE equilibrates a Hermitian matrix A using the scaling factors
+*  in the vector S.
+*
+*  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 EQUED = 'Y', the equilibrated matrix:
+*          diag(S) * A * diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J - 1
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   10          CONTINUE
+               A( J, J ) = CJ*CJ*DBLE( A( J, J ) )
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               A( J, J ) = CJ*CJ*DBLE( A( J, J ) )
+               DO 30 I = J + 1, N
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQHE
+*
+      END
diff --git a/SRC/zlaqhp.f b/SRC/zlaqhp.f
new file mode 100644
index 00000000..5e2dfa0d
--- /dev/null
+++ b/SRC/zlaqhp.f
@@ -0,0 +1,146 @@
+      SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQHP equilibrates a Hermitian matrix A using the scaling factors
+*  in the vector S.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
+*          the same storage format as A.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JC
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            JC = 1
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J - 1
+                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+   10          CONTINUE
+               AP( JC+J-1 ) = CJ*CJ*DBLE( AP( JC+J-1 ) )
+               JC = JC + J
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            JC = 1
+            DO 40 J = 1, N
+               CJ = S( J )
+               AP( JC ) = CJ*CJ*DBLE( AP( JC ) )
+               DO 30 I = J + 1, N
+                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+   30          CONTINUE
+               JC = JC + N - J + 1
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQHP
+*
+      END
diff --git a/SRC/zlaqp2.f b/SRC/zlaqp2.f
new file mode 100644
index 00000000..3acb25ec
--- /dev/null
+++ b/SRC/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, ZLARFP, 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 ZLARFP( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+     $                   TAU( I ) )
+         ELSE
+            CALL ZLARFP( 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/zlaqps.f b/SRC/zlaqps.f
new file mode 100644
index 00000000..754c1704
--- /dev/null
+++ b/SRC/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, ZLARFP, 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 ZLARFP( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+         ELSE
+            CALL ZLARFP( 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/zlaqr0.f b/SRC/zlaqr0.f
new file mode 100644
index 00000000..2a35a725
--- /dev/null
+++ b/SRC/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/zlaqr1.f b/SRC/zlaqr1.f
new file mode 100644
index 00000000..b8c1c3d4
--- /dev/null
+++ b/SRC/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/zlaqr2.f b/SRC/zlaqr2.f
new file mode 100644
index 00000000..0add51ae
--- /dev/null
+++ b/SRC/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/zlaqr3.f b/SRC/zlaqr3.f
new file mode 100644
index 00000000..e9bf393a
--- /dev/null
+++ b/SRC/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/zlaqr4.f b/SRC/zlaqr4.f
new file mode 100644
index 00000000..eef7f00a
--- /dev/null
+++ b/SRC/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/zlaqr5.f b/SRC/zlaqr5.f
new file mode 100644
index 00000000..fa8de7bb
--- /dev/null
+++ b/SRC/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/zlaqsb.f b/SRC/zlaqsb.f
new file mode 100644
index 00000000..b4d0e114
--- /dev/null
+++ b/SRC/zlaqsb.f
@@ -0,0 +1,149 @@
+      SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            KD, LDAB, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQSB equilibrates a symmetric band matrix A using the scaling
+*  factors in the vector S.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the symmetric band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored in band format.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = MAX( 1, J-KD ), J
+                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, MIN( N, J+KD )
+                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQSB
+*
+      END
diff --git a/SRC/zlaqsp.f b/SRC/zlaqsp.f
new file mode 100644
index 00000000..24dc55aa
--- /dev/null
+++ b/SRC/zlaqsp.f
@@ -0,0 +1,141 @@
+      SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQSP equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
+*          the same storage format as A.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, JC
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            JC = 1
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+   10          CONTINUE
+               JC = JC + J
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            JC = 1
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+   30          CONTINUE
+               JC = JC + N - J + 1
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQSP
+*
+      END
diff --git a/SRC/zlaqsy.f b/SRC/zlaqsy.f
new file mode 100644
index 00000000..2a08bed3
--- /dev/null
+++ b/SRC/zlaqsy.f
@@ -0,0 +1,142 @@
+      SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, UPLO
+      INTEGER            LDA, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQSY equilibrates a symmetric matrix A using the scaling factors
+*  in the vector S.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if EQUED = 'Y', the equilibrated matrix:
+*          diag(S) * A * diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  S       (input) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A.
+*
+*  SCOND   (input) DOUBLE PRECISION
+*          Ratio of the smallest S(i) to the largest S(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies whether or not equilibration was done.
+*          = 'N':  No equilibration.
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if scaling should be done
+*  based on the ratio of the scaling factors.  If SCOND < THRESH,
+*  scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if scaling should
+*  be done based on the absolute size of the largest matrix element.
+*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+*        No equilibration
+*
+         EQUED = 'N'
+      ELSE
+*
+*        Replace A by diag(S) * A * diag(S).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Upper triangle of A is stored.
+*
+            DO 20 J = 1, N
+               CJ = S( J )
+               DO 10 I = 1, J
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+*
+*           Lower triangle of A is stored.
+*
+            DO 40 J = 1, N
+               CJ = S( J )
+               DO 30 I = J, N
+                  A( I, J ) = CJ*S( I )*A( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         EQUED = 'Y'
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQSY
+*
+      END
diff --git a/SRC/zlar1v.f b/SRC/zlar1v.f
new file mode 100644
index 00000000..52d71250
--- /dev/null
+++ b/SRC/zlar1v.f
@@ -0,0 +1,371 @@
+      SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
+     $           PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+     $           R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTNC
+      INTEGER   B1, BN, N, NEGCNT, R
+      DOUBLE PRECISION   GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+     $                   RQCORR, ZTZ
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * )
+      DOUBLE PRECISION   D( * ), L( * ), LD( * ), LLD( * ),
+     $                  WORK( * )
+      COMPLEX*16       Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAR1V computes the (scaled) r-th column of the inverse of
+*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+*  L D L^T - sigma I. When sigma is close to an eigenvalue, the
+*  computed vector is an accurate eigenvector. Usually, r corresponds
+*  to the index where the eigenvector is largest in magnitude.
+*  The following steps accomplish this computation :
+*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
+*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+*  (c) Computation of the diagonal elements of the inverse of
+*      L D L^T - sigma I by combining the above transforms, and choosing
+*      r as the index where the diagonal of the inverse is (one of the)
+*      largest in magnitude.
+*  (d) Computation of the (scaled) r-th column of the inverse using the
+*      twisted factorization obtained by combining the top part of the
+*      the stationary and the bottom part of the progressive transform.
+*
+*  Arguments
+*  =========
+*
+*  N        (input) INTEGER
+*           The order of the matrix L D L^T.
+*
+*  B1       (input) INTEGER
+*           First index of the submatrix of L D L^T.
+*
+*  BN       (input) INTEGER
+*           Last index of the submatrix of L D L^T.
+*
+*  LAMBDA    (input) DOUBLE PRECISION
+*           The shift. In order to compute an accurate eigenvector,
+*           LAMBDA should be a good approximation to an eigenvalue
+*           of L D L^T.
+*
+*  L        (input) DOUBLE PRECISION array, dimension (N-1)
+*           The (n-1) subdiagonal elements of the unit bidiagonal matrix
+*           L, in elements 1 to N-1.
+*
+*  D        (input) DOUBLE PRECISION array, dimension (N)
+*           The n diagonal elements of the diagonal matrix D.
+*
+*  LD       (input) DOUBLE PRECISION array, dimension (N-1)
+*           The n-1 elements L(i)*D(i).
+*
+*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)
+*           The n-1 elements L(i)*L(i)*D(i).
+*
+*  PIVMIN   (input) DOUBLE PRECISION
+*           The minimum pivot in the Sturm sequence.
+*
+*  GAPTOL   (input) DOUBLE PRECISION
+*           Tolerance that indicates when eigenvector entries are negligible
+*           w.r.t. their contribution to the residual.
+*
+*  Z        (input/output) COMPLEX*16       array, dimension (N)
+*           On input, all entries of Z must be set to 0.
+*           On output, Z contains the (scaled) r-th column of the
+*           inverse. The scaling is such that Z(R) equals 1.
+*
+*  WANTNC   (input) LOGICAL
+*           Specifies whether NEGCNT has to be computed.
+*
+*  NEGCNT   (output) INTEGER
+*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+*  ZTZ      (output) DOUBLE PRECISION
+*           The square of the 2-norm of Z.
+*
+*  MINGMA   (output) DOUBLE PRECISION
+*           The reciprocal of the largest (in magnitude) diagonal
+*           element of the inverse of L D L^T - sigma I.
+*
+*  R        (input/output) INTEGER
+*           The twist index for the twisted factorization used to
+*           compute Z.
+*           On input, 0 <= R <= N. If R is input as 0, R is set to
+*           the index where (L D L^T - sigma I)^{-1} is largest
+*           in magnitude. If 1 <= R <= N, R is unchanged.
+*           On output, R contains the twist index used to compute Z.
+*           Ideally, R designates the position of the maximum entry in the
+*           eigenvector.
+*
+*  ISUPPZ   (output) INTEGER array, dimension (2)
+*           The support of the vector in Z, i.e., the vector Z is
+*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+*  NRMINV   (output) DOUBLE PRECISION
+*           NRMINV = 1/SQRT( ZTZ )
+*
+*  RESID    (output) DOUBLE PRECISION
+*           The residual of the FP vector.
+*           RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+*  RQCORR   (output) DOUBLE PRECISION
+*           The Rayleigh Quotient correction to LAMBDA.
+*           RQCORR = MINGMA*TMP
+*
+*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
+
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SAWNAN1, SAWNAN2
+      INTEGER            I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
+     $                   R2
+      DOUBLE PRECISION   DMINUS, DPLUS, EPS, S, TMP
+*     ..
+*     .. External Functions ..
+      LOGICAL DISNAN
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DISNAN, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = DLAMCH( 'Precision' )
+
+
+      IF( R.EQ.0 ) THEN
+         R1 = B1
+         R2 = BN
+      ELSE
+         R1 = R
+         R2 = R
+      END IF
+
+*     Storage for LPLUS
+      INDLPL = 0
+*     Storage for UMINUS
+      INDUMN = N
+      INDS = 2*N + 1
+      INDP = 3*N + 1
+
+      IF( B1.EQ.1 ) THEN
+         WORK( INDS ) = ZERO
+      ELSE
+         WORK( INDS+B1-1 ) = LLD( B1-1 )
+      END IF
+
+*
+*     Compute the stationary transform (using the differential form)
+*     until the index R2.
+*
+      SAWNAN1 = .FALSE.
+      NEG1 = 0
+      S = WORK( INDS+B1-1 ) - LAMBDA
+      DO 50 I = B1, R1 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 50   CONTINUE
+      SAWNAN1 = DISNAN( S )
+      IF( SAWNAN1 ) GOTO 60
+      DO 51 I = R1, R2 - 1
+         DPLUS = D( I ) + S
+         WORK( INDLPL+I ) = LD( I ) / DPLUS
+         WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+         S = WORK( INDS+I ) - LAMBDA
+ 51   CONTINUE
+      SAWNAN1 = DISNAN( S )
+*
+ 60   CONTINUE
+      IF( SAWNAN1 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG1 = 0
+         S = WORK( INDS+B1-1 ) - LAMBDA
+         DO 70 I = B1, R1 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 70      CONTINUE
+         DO 71 I = R1, R2 - 1
+            DPLUS = D( I ) + S
+            IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+            WORK( INDLPL+I ) = LD( I ) / DPLUS
+            WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+            IF( WORK( INDLPL+I ).EQ.ZERO )
+     $                      WORK( INDS+I ) = LLD( I )
+            S = WORK( INDS+I ) - LAMBDA
+ 71      CONTINUE
+      END IF
+*
+*     Compute the progressive transform (using the differential form)
+*     until the index R1
+*
+      SAWNAN2 = .FALSE.
+      NEG2 = 0
+      WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
+      DO 80 I = BN - 1, R1, -1
+         DMINUS = LLD( I ) + WORK( INDP+I )
+         TMP = D( I ) / DMINUS
+         IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+         WORK( INDUMN+I ) = L( I )*TMP
+         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ 80   CONTINUE
+      TMP = WORK( INDP+R1-1 )
+      SAWNAN2 = DISNAN( TMP )
+
+      IF( SAWNAN2 ) THEN
+*        Runs a slower version of the above loop if a NaN is detected
+         NEG2 = 0
+         DO 100 I = BN-1, R1, -1
+            DMINUS = LLD( I ) + WORK( INDP+I )
+            IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
+            TMP = D( I ) / DMINUS
+            IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+            WORK( INDUMN+I ) = L( I )*TMP
+            WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+            IF( TMP.EQ.ZERO )
+     $          WORK( INDP+I-1 ) = D( I ) - LAMBDA
+ 100     CONTINUE
+      END IF
+*
+*     Find the index (from R1 to R2) of the largest (in magnitude)
+*     diagonal element of the inverse
+*
+      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
+      IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
+      IF( WANTNC ) THEN
+         NEGCNT = NEG1 + NEG2
+      ELSE
+         NEGCNT = -1
+      ENDIF
+      IF( ABS(MINGMA).EQ.ZERO )
+     $   MINGMA = EPS*WORK( INDS+R1-1 )
+      R = R1
+      DO 110 I = R1, R2 - 1
+         TMP = WORK( INDS+I ) + WORK( INDP+I )
+         IF( TMP.EQ.ZERO )
+     $      TMP = EPS*WORK( INDS+I )
+         IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
+            MINGMA = TMP
+            R = I + 1
+         END IF
+ 110  CONTINUE
+*
+*     Compute the FP vector: solve N^T v = e_r
+*
+      ISUPPZ( 1 ) = B1
+      ISUPPZ( 2 ) = BN
+      Z( R ) = CONE
+      ZTZ = ONE
+*
+*     Compute the FP vector upwards from R
+*
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 210 I = R-1, B1, -1
+            Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GOTO 220
+            ENDIF
+            ZTZ = ZTZ + DBLE( Z( I )*Z( I ) )
+ 210     CONTINUE
+ 220     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 230 I = R - 1, B1, -1
+            IF( Z( I+1 ).EQ.ZERO ) THEN
+               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
+            ELSE
+               Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I ) = ZERO
+               ISUPPZ( 1 ) = I + 1
+               GO TO 240
+            END IF
+            ZTZ = ZTZ + DBLE( Z( I )*Z( I ) )
+ 230     CONTINUE
+ 240     CONTINUE
+      ENDIF
+
+*     Compute the FP vector downwards from R in blocks of size BLKSIZ
+      IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+         DO 250 I = R, BN-1
+            Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $         THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 260
+            END IF
+            ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) )
+ 250     CONTINUE
+ 260     CONTINUE
+      ELSE
+*        Run slower loop if NaN occurred.
+         DO 270 I = R, BN - 1
+            IF( Z( I ).EQ.ZERO ) THEN
+               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
+            ELSE
+               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+            END IF
+            IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+     $           THEN
+               Z( I+1 ) = ZERO
+               ISUPPZ( 2 ) = I
+               GO TO 280
+            END IF
+            ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) )
+ 270     CONTINUE
+ 280     CONTINUE
+      END IF
+*
+*     Compute quantities for convergence test
+*
+      TMP = ONE / ZTZ
+      NRMINV = SQRT( TMP )
+      RESID = ABS( MINGMA )*NRMINV
+      RQCORR = MINGMA*TMP
+*
+*
+      RETURN
+*
+*     End of ZLAR1V
+*
+      END
diff --git a/SRC/zlar2v.f b/SRC/zlar2v.f
new file mode 100644
index 00000000..cb87cb89
--- /dev/null
+++ b/SRC/zlar2v.f
@@ -0,0 +1,97 @@
+      SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * )
+      COMPLEX*16         S( * ), X( * ), Y( * ), Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAR2V applies a vector of complex plane rotations with real cosines
+*  from both sides to a sequence of 2-by-2 complex Hermitian matrices,
+*  defined by the elements of the vectors x, y and z. For i = 1,2,...,n
+*
+*     (       x(i)  z(i) ) :=
+*     ( conjg(z(i)) y(i) )
+*
+*       (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )
+*       ( -s(i)       c(i)  ) ( conjg(z(i)) y(i) ) ( s(i)        c(i)  )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)
+*          The vector x; the elements of x are assumed to be real.
+*
+*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)
+*          The vector y; the elements of y are assumed to be real.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)
+*          The vector z.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X, Y and Z. INCX > 0.
+*
+*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX
+      DOUBLE PRECISION   CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,
+     $                   ZIR
+      COMPLEX*16         SI, T2, T3, T4, ZI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DCONJG, DIMAG
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = DBLE( X( IX ) )
+         YI = DBLE( Y( IX ) )
+         ZI = Z( IX )
+         ZIR = DBLE( ZI )
+         ZII = DIMAG( ZI )
+         CI = C( IC )
+         SI = S( IC )
+         SIR = DBLE( SI )
+         SII = DIMAG( SI )
+         T1R = SIR*ZIR - SII*ZII
+         T1I = SIR*ZII + SII*ZIR
+         T2 = CI*ZI
+         T3 = T2 - DCONJG( SI )*XI
+         T4 = DCONJG( T2 ) + SI*YI
+         T5 = CI*XI + T1R
+         T6 = CI*YI - T1R
+         X( IX ) = CI*T5 + ( SIR*DBLE( T4 )+SII*DIMAG( T4 ) )
+         Y( IX ) = CI*T6 - ( SIR*DBLE( T3 )-SII*DIMAG( T3 ) )
+         Z( IX ) = CI*T3 + DCONJG( SI )*DCMPLX( T6, T1I )
+         IX = IX + INCX
+         IC = IC + INCC
+   10 CONTINUE
+      RETURN
+*
+*     End of ZLAR2V
+*
+      END
diff --git a/SRC/zlarcm.f b/SRC/zlarcm.f
new file mode 100644
index 00000000..03f7be0c
--- /dev/null
+++ b/SRC/zlarcm.f
@@ -0,0 +1,110 @@
+      SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDB, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), RWORK( * )
+      COMPLEX*16         B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARCM performs a very simple matrix-matrix multiplication:
+*           C := A * B,
+*  where A is M by M and real; B is M by N and complex;
+*  C is M by N and complex.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A and of the matrix C.
+*          M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns and rows of the matrix B and
+*          the number of columns of the matrix C.
+*          N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)
+*          A contains the M by M matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >=max(1,M).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
+*          B contains the M by N matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >=max(1,M).
+*
+*  C       (input) COMPLEX*16 array, dimension (LDC, N)
+*          C contains the M by N matrix C.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >=max(1,M).
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*M*N)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DIMAG
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+     $   RETURN
+*
+      DO 20 J = 1, N
+         DO 10 I = 1, M
+            RWORK( ( J-1 )*M+I ) = DBLE( B( I, J ) )
+   10    CONTINUE
+   20 CONTINUE
+*
+      L = M*N + 1
+      CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
+     $            RWORK( L ), M )
+      DO 40 J = 1, N
+         DO 30 I = 1, M
+            C( I, J ) = RWORK( L+( J-1 )*M+I-1 )
+   30    CONTINUE
+   40 CONTINUE
+*
+      DO 60 J = 1, N
+         DO 50 I = 1, M
+            RWORK( ( J-1 )*M+I ) = DIMAG( B( I, J ) )
+   50    CONTINUE
+   60 CONTINUE
+      CALL DGEMM( 'N', 'N', M, N, M, ONE, A, LDA, RWORK, M, ZERO,
+     $            RWORK( L ), M )
+      DO 80 J = 1, N
+         DO 70 I = 1, M
+            C( I, J ) = DCMPLX( DBLE( C( I, J ) ),
+     $                  RWORK( L+( J-1 )*M+I-1 ) )
+   70    CONTINUE
+   80 CONTINUE
+*
+      RETURN
+*
+*     End of ZLARCM
+*
+      END
diff --git a/SRC/zlarf.f b/SRC/zlarf.f
new file mode 100644
index 00000000..a23f210d
--- /dev/null
+++ b/SRC/zlarf.f
@@ -0,0 +1,157 @@
+      SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            APPLYLEFT
+      INTEGER            I, LASTV, LASTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZGERC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAZLR, ILAZLC
+      EXTERNAL           LSAME, ILAZLR, ILAZLC
+*     ..
+*     .. Executable Statements ..
+*
+      APPLYLEFT = LSAME( SIDE, 'L' )
+      LASTV = 0
+      LASTC = 0
+      IF( TAU.NE.ZERO ) THEN
+!     Set up variables for scanning V.  LASTV begins pointing to the end
+!     of V.
+         IF( APPLYLEFT ) THEN
+            LASTV = M
+         ELSE
+            LASTV = N
+         END IF
+         IF( INCV.GT.0 ) THEN
+            I = 1 + (LASTV-1) * INCV
+         ELSE
+            I = 1
+         END IF
+!     Look for the last non-zero row in V.
+         DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
+            LASTV = LASTV - 1
+            I = I - INCV
+         END DO
+         IF( APPLYLEFT ) THEN
+!     Scan for the last non-zero column in C(1:lastv,:).
+            LASTC = ILAZLC(LASTV, N, C, LDC)
+         ELSE
+!     Scan for the last non-zero row in C(:,1:lastv).
+            LASTC = ILAZLR(M, LASTV, C, LDC)
+         END IF
+      END IF
+!     Note that lastc.eq.0 renders the BLAS operations null; no special
+!     case is needed at this level.
+      IF( APPLYLEFT ) THEN
+*
+*        Form  H * C
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
+*
+            CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
+     $           C, LDC, V, INCV, ZERO, WORK, 1 )
+*
+*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
+*
+            CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( LASTV.GT.0 ) THEN
+*
+*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
+*
+            CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
+     $           V, INCV, ZERO, WORK, 1 )
+*
+*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
+*
+            CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLARF
+*
+      END
diff --git a/SRC/zlarfb.f b/SRC/zlarfb.f
new file mode 100644
index 00000000..112d592c
--- /dev/null
+++ b/SRC/zlarfb.f
@@ -0,0 +1,652 @@
+      SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+      IMPLICIT NONE
+*
+*  -- 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, LASTV, LASTC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAZLR, ILAZLC
+      EXTERNAL           LSAME, ILAZLR, ILAZLC
+*     ..
+*     .. 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 )
+*
+               LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
+               LASTC = ILAZLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, 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',
+     $                 LASTV-K, LASTC, 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', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
+               LASTC = ILAZLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, LASTV-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', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
+               LASTC = ILAZLC( LASTV, N, C, LDC )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+                  CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C, LDC, V, LDV,
+     $                 ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTV-K, LASTC, K,
+     $                 -ONE, V, LDV, WORK, LDWORK,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-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 )
+*
+               LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
+               LASTC = ILAZLR( M, LASTV, C, LDC )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
+     $                 WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, K, LASTV-K,
+     $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-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 )
+*
+               LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
+               LASTC = ILAZLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTV-K, LASTC, 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',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
+               LASTC = ILAZLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, K, LASTV-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',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-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',
+     $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, LASTC
+                     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 )
+*
+               LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
+               LASTC = ILAZLC( LASTV, N, C, LDC )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
+     $                 WORK( 1, J ), 1 )
+                  CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTC, K, LASTV-K,
+     $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                 'Conjugate transpose', LASTV-K, LASTC, K,
+     $                 -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, LASTC
+                     C( LASTV-K+J, I ) = C( LASTV-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 )
+*
+               LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
+               LASTC = ILAZLR( M, LASTV, C, LDC )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
+     $                 WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+               IF( LASTV.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
+     $                 WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
+     $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( LASTV.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose',
+     $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
+     $                 ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
+     $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
+     $              WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, LASTC
+                     C( I, LASTV-K+J ) = C( I, LASTV-K+J )
+     $                    - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFB
+*
+      END
diff --git a/SRC/zlarfg.f b/SRC/zlarfg.f
new file mode 100644
index 00000000..f1e09dca
--- /dev/null
+++ b/SRC/zlarfg.f
@@ -0,0 +1,140 @@
+      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
+*
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+   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 )
+         END IF
+         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
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFG
+*
+      END
diff --git a/SRC/zlarfp.f b/SRC/zlarfp.f
new file mode 100644
index 00000000..91190ba5
--- /dev/null
+++ b/SRC/zlarfp.f
@@ -0,0 +1,172 @@
+      SUBROUTINE ZLARFP( 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
+*  =======
+*
+*  ZLARFP 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, beta is real and non-negative, 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   TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0D+0, 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, DLAPY2, DZNRM2
+      COMPLEX*16         ZLADIV
+      EXTERNAL           DLAMCH, DLAPY3, DLAPY2, 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  =  [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0.
+*
+         IF( ALPHI.EQ.ZERO ) THEN
+            IF( ALPHR.GE.ZERO ) THEN
+!              When TAU.eq.ZERO, the vector is special-cased to be
+!              all zeros in the application routines.  We do not need
+!              to clear it.
+               TAU = ZERO
+            ELSE
+!              However, the application routines rely on explicit
+!              zero checks when TAU.ne.ZERO, and we must clear X.
+               TAU = TWO
+               DO J = 1, N-1
+                  X( 1 + (J-1)*INCX ) = 0
+               END DO
+               ALPHA = -ALPHA
+            END IF
+         ELSE
+!           Only "reflecting" the diagonal entry to be real and non-negative.
+            XNORM = DLAPY2( ALPHR, ALPHI )
+            TAU = CMPLX( ONE - ALPHR / XNORM, -ALPHI / XNORM )
+            DO J = 1, N-1
+               X( 1 + (J-1)*INCX ) = 0
+            END DO
+            ALPHA = XNORM
+         END IF
+      ELSE
+*
+*        general case
+*
+         BETA = SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         RSAFMN = ONE / SAFMIN
+*
+         KNT = 0
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+   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 )
+         END IF
+         ALPHA = ALPHA + BETA
+         IF( BETA.LT.ZERO ) THEN
+            BETA = -BETA
+            TAU = -ALPHA / BETA
+         ELSE
+            ALPHR = ALPHI * (ALPHI/DBLE( ALPHA ))
+            ALPHR = ALPHR + XNORM * (XNORM/DBLE( ALPHA ))
+            TAU = DCMPLX( ALPHR/BETA, -ALPHI/BETA )
+            ALPHA = DCMPLX( -ALPHR, ALPHI )
+         END IF
+         ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA )
+         CALL ZSCAL( N-1, ALPHA, X, INCX )
+*
+*        If BETA is subnormal, it may lose relative accuracy
+*
+         DO 20 J = 1, KNT
+            BETA = BETA*SAFMIN
+ 20      CONTINUE
+         ALPHA = BETA
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFP
+*
+      END
diff --git a/SRC/zlarft.f b/SRC/zlarft.f
new file mode 100644
index 00000000..04006158
--- /dev/null
+++ b/SRC/zlarft.f
@@ -0,0 +1,257 @@
+      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, PREVLASTV, LASTV
+      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
+         PREVLASTV = N
+         DO 20 I = 1, K
+            PREVLASTV = MAX( PREVLASTV, I )
+            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
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( LASTV, I ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i)
+*
+                  CALL ZGEMV( 'Conjugate transpose', J-I+1, I-1,
+     $                        -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1,
+     $                        ZERO, T( 1, I ), 1 )
+               ELSE
+!                 Skip any trailing zeros.
+                  DO LASTV = N, I+1, -1
+                     IF( V( I, LASTV ).NE.ZERO ) EXIT
+                  END DO
+                  J = MIN( LASTV, PREVLASTV )
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)'
+*
+                  IF( I.LT.J )
+     $               CALL ZLACGV( J-I, V( I, I+1 ), LDV )
+                  CALL ZGEMV( 'No transpose', I-1, J-I+1, -TAU( I ),
+     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+     $                        T( 1, I ), 1 )
+                  IF( I.LT.J )
+     $               CALL ZLACGV( J-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 )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MAX( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+             END IF
+   20    CONTINUE
+      ELSE
+         PREVLASTV = 1
+         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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( LASTV, I ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i)
+*
+                     CALL ZGEMV( 'Conjugate transpose', N-K+I-J+1, K-I,
+     $                           -TAU( I ), V( J, I+1 ), LDV, V( J, 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
+!                    Skip any leading zeros.
+                     DO LASTV = 1, I-1
+                        IF( V( I, LASTV ).NE.ZERO ) EXIT
+                     END DO
+                     J = MAX( LASTV, PREVLASTV )
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)'
+*
+                     CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV )
+                     CALL ZGEMV( 'No transpose', K-I, N-K+I-J+1,
+     $                    -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV,
+     $                    ZERO, T( I+1, I ), 1 )
+                     CALL ZLACGV( N-K+I-1-J+1, V( I, J ), 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 )
+               IF( I.GT.1 ) THEN
+                  PREVLASTV = MIN( PREVLASTV, LASTV )
+               ELSE
+                  PREVLASTV = LASTV
+               END IF
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZLARFT
+*
+      END
diff --git a/SRC/zlarfx.f b/SRC/zlarfx.f
new file mode 100644
index 00000000..878e709b
--- /dev/null
+++ b/SRC/zlarfx.f
@@ -0,0 +1,628 @@
+      SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+      IMPLICIT NONE
+*
+*  -- 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           ZLARF
+*     ..
+*     .. 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
+*
+         CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*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
+*
+         CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*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/zlargv.f b/SRC/zlargv.f
new file mode 100644
index 00000000..4ef36fc3
--- /dev/null
+++ b/SRC/zlargv.f
@@ -0,0 +1,228 @@
+      SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * )
+      COMPLEX*16         X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARGV generates a vector of complex plane rotations with real
+*  cosines, determined by elements of the complex vectors x and y.
+*  For i = 1,2,...,n
+*
+*     (        c(i)   s(i) ) ( x(i) ) = ( r(i) )
+*     ( -conjg(s(i))  c(i) ) ( y(i) ) = (   0  )
+*
+*     where c(i)**2 + ABS(s(i))**2 = 1
+*
+*  The following conventions are used (these are the same as in ZLARTG,
+*  but differ from the BLAS1 routine ZROTG):
+*     If y(i)=0, then c(i)=1 and s(i)=0.
+*     If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be generated.
+*
+*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)
+*          On entry, the vector x.
+*          On exit, x(i) is overwritten by r(i), for i = 1,...,n.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)
+*          On entry, the vector y.
+*          On exit, the sines of the plane rotations.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C. INCC > 0.
+*
+*  Further Details
+*  ======= =======
+*
+*  6-6-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, IC, IX, IY, J
+      DOUBLE PRECISION   CS, D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
+     $                   SAFMN2, SAFMX2, SCALE
+      COMPLEX*16         F, FF, FS, G, GS, R, SN
+*     ..
+*     .. 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
+*        FIRST = .FALSE.
+         SAFMIN = DLAMCH( 'S' )
+         EPS = DLAMCH( 'E' )
+         SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( DLAMCH( 'B' ) ) / TWO )
+         SAFMX2 = ONE / SAFMN2
+*     END IF
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 60 I = 1, N
+         F = X( IX )
+         G = Y( IY )
+*
+*        Use identical algorithm as in ZLARTG
+*
+         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
+               GO TO 50
+            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 )
+               GO TO 50
+            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 J = 1, COUNT
+                     R = R*SAFMX2
+   30             CONTINUE
+               ELSE
+                  DO 40 J = 1, -COUNT
+                     R = R*SAFMN2
+   40             CONTINUE
+               END IF
+            END IF
+         END IF
+   50    CONTINUE
+         C( IC ) = CS
+         Y( IY ) = SN
+         X( IX ) = R
+         IC = IC + INCC
+         IY = IY + INCY
+         IX = IX + INCX
+   60 CONTINUE
+      RETURN
+*
+*     End of ZLARGV
+*
+      END
diff --git a/SRC/zlarnv.f b/SRC/zlarnv.f
new file mode 100644
index 00000000..78656a12
--- /dev/null
+++ b/SRC/zlarnv.f
@@ -0,0 +1,130 @@
+      SUBROUTINE ZLARNV( IDIST, ISEED, N, X )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IDIST, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISEED( 4 )
+      COMPLEX*16         X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARNV returns a vector of n random complex numbers from a uniform or
+*  normal distribution.
+*
+*  Arguments
+*  =========
+*
+*  IDIST   (input) INTEGER
+*          Specifies the distribution of the random numbers:
+*          = 1:  real and imaginary parts each uniform (0,1)
+*          = 2:  real and imaginary parts each uniform (-1,1)
+*          = 3:  real and imaginary parts each normal (0,1)
+*          = 4:  uniformly distributed on the disc abs(z) < 1
+*          = 5:  uniformly distributed on the circle abs(z) = 1
+*
+*  ISEED   (input/output) INTEGER array, dimension (4)
+*          On entry, the seed of the random number generator; the array
+*          elements must be between 0 and 4095, and ISEED(4) must be
+*          odd.
+*          On exit, the seed is updated.
+*
+*  N       (input) INTEGER
+*          The number of random numbers to be generated.
+*
+*  X       (output) COMPLEX*16 array, dimension (N)
+*          The generated random numbers.
+*
+*  Further Details
+*  ===============
+*
+*  This routine calls the auxiliary routine DLARUV to generate random
+*  real numbers from a uniform (0,1) distribution, in batches of up to
+*  128 using vectorisable code. The Box-Muller method is used to
+*  transform numbers from a uniform to a normal distribution.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+      INTEGER            LV
+      PARAMETER          ( LV = 128 )
+      DOUBLE PRECISION   TWOPI
+      PARAMETER          ( TWOPI = 6.2831853071795864769252867663D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IL, IV
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   U( LV )
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCMPLX, EXP, LOG, MIN, SQRT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARUV
+*     ..
+*     .. Executable Statements ..
+*
+      DO 60 IV = 1, N, LV / 2
+         IL = MIN( LV / 2, N-IV+1 )
+*
+*        Call DLARUV to generate 2*IL real numbers from a uniform (0,1)
+*        distribution (2*IL <= LV)
+*
+         CALL DLARUV( ISEED, 2*IL, U )
+*
+         IF( IDIST.EQ.1 ) THEN
+*
+*           Copy generated numbers
+*
+            DO 10 I = 1, IL
+               X( IV+I-1 ) = DCMPLX( U( 2*I-1 ), U( 2*I ) )
+   10       CONTINUE
+         ELSE IF( IDIST.EQ.2 ) THEN
+*
+*           Convert generated numbers to uniform (-1,1) distribution
+*
+            DO 20 I = 1, IL
+               X( IV+I-1 ) = DCMPLX( TWO*U( 2*I-1 )-ONE,
+     $                       TWO*U( 2*I )-ONE )
+   20       CONTINUE
+         ELSE IF( IDIST.EQ.3 ) THEN
+*
+*           Convert generated numbers to normal (0,1) distribution
+*
+            DO 30 I = 1, IL
+               X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
+     $                       EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) )
+   30       CONTINUE
+         ELSE IF( IDIST.EQ.4 ) THEN
+*
+*           Convert generated numbers to complex numbers uniformly
+*           distributed on the unit disk
+*
+            DO 40 I = 1, IL
+               X( IV+I-1 ) = SQRT( U( 2*I-1 ) )*
+     $                       EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) )
+   40       CONTINUE
+         ELSE IF( IDIST.EQ.5 ) THEN
+*
+*           Convert generated numbers to complex numbers uniformly
+*           distributed on the unit circle
+*
+            DO 50 I = 1, IL
+               X( IV+I-1 ) = EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) )
+   50       CONTINUE
+         END IF
+   60 CONTINUE
+      RETURN
+*
+*     End of ZLARNV
+*
+      END
diff --git a/SRC/zlarrv.f b/SRC/zlarrv.f
new file mode 100644
index 00000000..665d9382
--- /dev/null
+++ b/SRC/zlarrv.f
@@ -0,0 +1,916 @@
+      SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN,
+     $                   ISPLIT, M, DOL, DOU, MINRGP,
+     $                   RTOL1, RTOL2, W, WERR, WGAP,
+     $                   IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            DOL, DOU, INFO, LDZ, M, N
+      DOUBLE PRECISION   MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+     $                   ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
+     $                   WGAP( * ), WORK( * )
+      COMPLEX*16        Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARRV computes the eigenvectors of the tridiagonal matrix
+*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
+*  The input eigenvalues should have been computed by DLARRE.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          Lower and upper bounds of the interval that contains the desired
+*          eigenvalues. VL < VU. Needed to compute gaps on the left or right
+*          end of the extremal eigenvalues in the desired RANGE.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the diagonal matrix D.
+*          On exit, D may be overwritten.
+*
+*  L       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the unit
+*          bidiagonal matrix L are in elements 1 to N-1 of L
+*          (if the matrix is not splitted.) At the end of each block
+*          is stored the corresponding shift as given by DLARRE.
+*          On exit, L is overwritten.
+*
+*  PIVMIN  (in) DOUBLE PRECISION
+*          The minimum pivot allowed in the Sturm sequence.
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into blocks.
+*          The first block consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*
+*  M       (input) INTEGER
+*          The total number of input eigenvalues.  0 <= M <= N.
+*
+*  DOL     (input) INTEGER
+*  DOU     (input) INTEGER
+*          If the user wants to compute only selected eigenvectors from all
+*          the eigenvalues supplied, he can specify an index range DOL:DOU.
+*          Or else the setting DOL=1, DOU=M should be applied.
+*          Note that DOL and DOU refer to the order in which the eigenvalues
+*          are stored in W.
+*          If the user wants to compute only selected eigenpairs, then
+*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+*          computed eigenvectors. All other columns of Z are set to zero.
+*
+*  MINRGP  (input) DOUBLE PRECISION
+*
+*  RTOL1   (input) DOUBLE PRECISION
+*  RTOL2   (input) DOUBLE PRECISION
+*           Parameters for bisection.
+*           An interval [LEFT,RIGHT] has converged if
+*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+*  W       (input/output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements of W contain the APPROXIMATE eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block ( The output array
+*          W from DLARRE is expected here ). Furthermore, they are with
+*          respect to the shift of the corresponding root representation
+*          for their block. On exit, W holds the eigenvalues of the
+*          UNshifted matrix.
+*
+*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the semiwidth of the uncertainty
+*          interval of the corresponding eigenvalue in W
+*
+*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N)
+*          The separation from the right neighbor eigenvalue in W.
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The indices of the blocks (submatrices) associated with the
+*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+*          W(i) belongs to the first block from the top, =2 if W(i)
+*          belongs to the second block, etc.
+*
+*  INDEXW  (input) INTEGER array, dimension (N)
+*          The indices of the eigenvalues within each block (submatrix);
+*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+*  GERS    (input) DOUBLE PRECISION array, dimension (2*N)
+*          The N Gerschgorin intervals (the i-th Gerschgorin interval
+*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+*          be computed from the original UNshifted matrix.
+*
+*  Z       (output) COMPLEX*16       array, dimension (LDZ, max(1,M) )
+*          If INFO = 0, the first M columns of Z contain the
+*          orthonormal eigenvectors of the matrix T
+*          corresponding to the input eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The I-th eigenvector
+*          is nonzero only in elements ISUPPZ( 2*I-1 ) through
+*          ISUPPZ( 2*I ).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (12*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (7*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*
+*          > 0:  A problem occured in ZLARRV.
+*          < 0:  One of the called subroutines signaled an internal problem.
+*                Needs inspection of the corresponding parameter IINFO
+*                for further information.
+*
+*          =-1:  Problem in DLARRB when refining a child's eigenvalues.
+*          =-2:  Problem in DLARRF when computing the RRR of a child.
+*                When a child is inside a tight cluster, it can be difficult
+*                to find an RRR. A partial remedy from the user's point of
+*                view is to make the parameter MINRGP smaller and recompile.
+*                However, as the orthogonality of the computed vectors is
+*                proportional to 1/MINRGP, the user should be aware that
+*                he might be trading in precision when he decreases MINRGP.
+*          =-3:  Problem in DLARRB when refining a single eigenvalue
+*                after the Rayleigh correction was rejected.
+*          = 5:  The Rayleigh Quotient Iteration failed to converge to
+*                full accuracy in MAXITR steps.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXITR
+      PARAMETER          ( MAXITR = 10 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ) )
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, HALF
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0,
+     $                     TWO = 2.0D0, THREE = 3.0D0,
+     $                     FOUR = 4.0D0, HALF = 0.5D0)
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
+      INTEGER            DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
+     $                   IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
+     $                   INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
+     $                   ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
+     $                   NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
+     $                   NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
+     $                   OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
+     $                   WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
+     $                   ZUSEDW
+      INTEGER            INDIN1, INDIN2
+      DOUBLE PRECISION   BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
+     $                   LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
+     $                   RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
+     $                   SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLARRB, DLARRF, ZDSCAL, ZLAR1V,
+     $                   ZLASET
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS, DBLE, MAX, MIN
+      INTRINSIC DCMPLX
+*     ..
+*     .. Executable Statements ..
+*     ..
+
+*     The first N entries of WORK are reserved for the eigenvalues
+      INDLD = N+1
+      INDLLD= 2*N+1
+      INDIN1 = 3*N + 1
+      INDIN2 = 4*N + 1
+      INDWRK = 5*N + 1
+      MINWSIZE = 12 * N
+
+      DO 5 I= 1,MINWSIZE
+         WORK( I ) = ZERO
+ 5    CONTINUE
+
+*     IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
+*     factorization used to compute the FP vector
+      IINDR = 0
+*     IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
+*     layer and the one above.
+      IINDC1 = N
+      IINDC2 = 2*N
+      IINDWK = 3*N + 1
+
+      MINIWSIZE = 7 * N
+      DO 10 I= 1,MINIWSIZE
+         IWORK( I ) = 0
+ 10   CONTINUE
+
+      ZUSEDL = 1
+      IF(DOL.GT.1) THEN
+*        Set lower bound for use of Z
+         ZUSEDL = DOL-1
+      ENDIF
+      ZUSEDU = M
+      IF(DOU.LT.M) THEN
+*        Set lower bound for use of Z
+         ZUSEDU = DOU+1
+      ENDIF
+*     The width of the part of Z that is used
+      ZUSEDW = ZUSEDU - ZUSEDL + 1
+
+
+      CALL ZLASET( 'Full', N, ZUSEDW, CZERO, CZERO,
+     $                    Z(1,ZUSEDL), LDZ )
+
+      EPS = DLAMCH( 'Precision' )
+      RQTOL = TWO * EPS
+*
+*     Set expert flags for standard code.
+      TRYRQC = .TRUE.
+
+      IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+      ELSE
+*        Only selected eigenpairs are computed. Since the other evalues
+*        are not refined by RQ iteration, bisection has to compute to full
+*        accuracy.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ENDIF
+
+*     The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
+*     desired eigenvalues. The support of the nonzero eigenvector
+*     entries is contained in the interval IBEGIN:IEND.
+*     Remark that if k eigenpairs are desired, then the eigenvectors
+*     are stored in k contiguous columns of Z.
+
+*     DONE is the number of eigenvectors already computed
+      DONE = 0
+      IBEGIN = 1
+      WBEGIN = 1
+      DO 170 JBLK = 1, IBLOCK( M )
+         IEND = ISPLIT( JBLK )
+         SIGMA = L( IEND )
+*        Find the eigenvectors of the submatrix indexed IBEGIN
+*        through IEND.
+         WEND = WBEGIN - 1
+ 15      CONTINUE
+         IF( WEND.LT.M ) THEN
+            IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+               WEND = WEND + 1
+               GO TO 15
+            END IF
+         END IF
+         IF( WEND.LT.WBEGIN ) THEN
+            IBEGIN = IEND + 1
+            GO TO 170
+         ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+            GO TO 170
+         END IF
+
+*        Find local spectral diameter of the block
+         GL = GERS( 2*IBEGIN-1 )
+         GU = GERS( 2*IBEGIN )
+         DO 20 I = IBEGIN+1 , IEND
+            GL = MIN( GERS( 2*I-1 ), GL )
+            GU = MAX( GERS( 2*I ), GU )
+ 20      CONTINUE
+         SPDIAM = GU - GL
+
+*        OLDIEN is the last index of the previous block
+         OLDIEN = IBEGIN - 1
+*        Calculate the size of the current block
+         IN = IEND - IBEGIN + 1
+*        The number of eigenvalues in the current block
+         IM = WEND - WBEGIN + 1
+
+*        This is for a 1x1 block
+         IF( IBEGIN.EQ.IEND ) THEN
+            DONE = DONE+1
+            Z( IBEGIN, WBEGIN ) = DCMPLX( ONE, ZERO )
+            ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
+            ISUPPZ( 2*WBEGIN ) = IBEGIN
+            W( WBEGIN ) = W( WBEGIN ) + SIGMA
+            WORK( WBEGIN ) = W( WBEGIN )
+            IBEGIN = IEND + 1
+            WBEGIN = WBEGIN + 1
+            GO TO 170
+         END IF
+
+*        The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
+*        Note that these can be approximations, in this case, the corresp.
+*        entries of WERR give the size of the uncertainty interval.
+*        The eigenvalue approximations will be refined when necessary as
+*        high relative accuracy is required for the computation of the
+*        corresponding eigenvectors.
+         CALL DCOPY( IM, W( WBEGIN ), 1,
+     &                   WORK( WBEGIN ), 1 )
+
+*        We store in W the eigenvalue approximations w.r.t. the original
+*        matrix T.
+         DO 30 I=1,IM
+            W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 30      CONTINUE
+
+
+*        NDEPTH is the current depth of the representation tree
+         NDEPTH = 0
+*        PARITY is either 1 or 0
+         PARITY = 1
+*        NCLUS is the number of clusters for the next level of the
+*        representation tree, we start with NCLUS = 1 for the root
+         NCLUS = 1
+         IWORK( IINDC1+1 ) = 1
+         IWORK( IINDC1+2 ) = IM
+
+*        IDONE is the number of eigenvectors already computed in the current
+*        block
+         IDONE = 0
+*        loop while( IDONE.LT.IM )
+*        generate the representation tree for the current block and
+*        compute the eigenvectors
+   40    CONTINUE
+         IF( IDONE.LT.IM ) THEN
+*           This is a crude protection against infinitely deep trees
+            IF( NDEPTH.GT.M ) THEN
+               INFO = -2
+               RETURN
+            ENDIF
+*           breadth first processing of the current level of the representation
+*           tree: OLDNCL = number of clusters on current level
+            OLDNCL = NCLUS
+*           reset NCLUS to count the number of child clusters
+            NCLUS = 0
+*
+            PARITY = 1 - PARITY
+            IF( PARITY.EQ.0 ) THEN
+               OLDCLS = IINDC1
+               NEWCLS = IINDC2
+            ELSE
+               OLDCLS = IINDC2
+               NEWCLS = IINDC1
+            END IF
+*           Process the clusters on the current level
+            DO 150 I = 1, OLDNCL
+               J = OLDCLS + 2*I
+*              OLDFST, OLDLST = first, last index of current cluster.
+*                               cluster indices start with 1 and are relative
+*                               to WBEGIN when accessing W, WGAP, WERR, Z
+               OLDFST = IWORK( J-1 )
+               OLDLST = IWORK( J )
+               IF( NDEPTH.GT.0 ) THEN
+*                 Retrieve relatively robust representation (RRR) of cluster
+*                 that has been computed at the previous level
+*                 The RRR is stored in Z and overwritten once the eigenvectors
+*                 have been computed or when the cluster is refined
+
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Get representation from location of the leftmost evalue
+*                    of the cluster
+                     J = WBEGIN + OLDFST - 1
+                  ELSE
+                     IF(WBEGIN+OLDFST-1.LT.DOL) THEN
+*                       Get representation from the left end of Z array
+                        J = DOL - 1
+                     ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
+*                       Get representation from the right end of Z array
+                        J = DOU
+                     ELSE
+                        J = WBEGIN + OLDFST - 1
+                     ENDIF
+                  ENDIF
+                  DO 45 K = 1, IN - 1
+                     D( IBEGIN+K-1 ) = DBLE( Z( IBEGIN+K-1,
+     $                                 J ) )
+                     L( IBEGIN+K-1 ) = DBLE( Z( IBEGIN+K-1,
+     $                                 J+1 ) )
+   45             CONTINUE
+                  D( IEND ) = DBLE( Z( IEND, J ) )
+                  SIGMA = DBLE( Z( IEND, J+1 ) )
+
+*                 Set the corresponding entries in Z to zero
+                  CALL ZLASET( 'Full', IN, 2, CZERO, CZERO,
+     $                         Z( IBEGIN, J), LDZ )
+               END IF
+
+*              Compute DL and DLL of current RRR
+               DO 50 J = IBEGIN, IEND-1
+                  TMP = D( J )*L( J )
+                  WORK( INDLD-1+J ) = TMP
+                  WORK( INDLLD-1+J ) = TMP*L( J )
+   50          CONTINUE
+
+               IF( NDEPTH.GT.0 ) THEN
+*                 P and Q are index of the first and last eigenvalue to compute
+*                 within the current block
+                  P = INDEXW( WBEGIN-1+OLDFST )
+                  Q = INDEXW( WBEGIN-1+OLDLST )
+*                 Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
+*                 thru' Q-OFFSET elements of these arrays are to be used.
+C                  OFFSET = P-OLDFST
+                  OFFSET = INDEXW( WBEGIN ) - 1
+*                 perform limited bisection (if necessary) to get approximate
+*                 eigenvalues to the precision needed.
+                  CALL DLARRB( IN, D( IBEGIN ),
+     $                         WORK(INDLLD+IBEGIN-1),
+     $                         P, Q, RTOL1, RTOL2, OFFSET,
+     $                         WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+     $                         WORK( INDWRK ), IWORK( IINDWK ),
+     $                         PIVMIN, SPDIAM, IN, IINFO )
+                  IF( IINFO.NE.0 ) THEN
+                     INFO = -1
+                     RETURN
+                  ENDIF
+*                 We also recompute the extremal gaps. W holds all eigenvalues
+*                 of the unshifted matrix and must be used for computation
+*                 of WGAP, the entries of WORK might stem from RRRs with
+*                 different shifts. The gaps from WBEGIN-1+OLDFST to
+*                 WBEGIN-1+OLDLST are correctly computed in DLARRB.
+*                 However, we only allow the gaps to become greater since
+*                 this is what should happen when we decrease WERR
+                  IF( OLDFST.GT.1) THEN
+                     WGAP( WBEGIN+OLDFST-2 ) =
+     $             MAX(WGAP(WBEGIN+OLDFST-2),
+     $                 W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
+     $                 - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
+                  ENDIF
+                  IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
+                     WGAP( WBEGIN+OLDLST-1 ) =
+     $               MAX(WGAP(WBEGIN+OLDLST-1),
+     $                   W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
+     $                   - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
+                  ENDIF
+*                 Each time the eigenvalues in WORK get refined, we store
+*                 the newly found approximation with all shifts applied in W
+                  DO 53 J=OLDFST,OLDLST
+                     W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
+ 53               CONTINUE
+               END IF
+
+*              Process the current node.
+               NEWFST = OLDFST
+               DO 140 J = OLDFST, OLDLST
+                  IF( J.EQ.OLDLST ) THEN
+*                    we are at the right end of the cluster, this is also the
+*                    boundary of the child cluster
+                     NEWLST = J
+                  ELSE IF ( WGAP( WBEGIN + J -1).GE.
+     $                    MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+*                    the right relative gap is big enough, the child cluster
+*                    (NEWFST,..,NEWLST) is well separated from the following
+                     NEWLST = J
+                   ELSE
+*                    inside a child cluster, the relative gap is not
+*                    big enough.
+                     GOTO 140
+                  END IF
+
+*                 Compute size of child cluster found
+                  NEWSIZ = NEWLST - NEWFST + 1
+
+*                 NEWFTT is the place in Z where the new RRR or the computed
+*                 eigenvector is to be stored
+                  IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+*                    Store representation at location of the leftmost evalue
+*                    of the cluster
+                     NEWFTT = WBEGIN + NEWFST - 1
+                  ELSE
+                     IF(WBEGIN+NEWFST-1.LT.DOL) THEN
+*                       Store representation at the left end of Z array
+                        NEWFTT = DOL - 1
+                     ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
+*                       Store representation at the right end of Z array
+                        NEWFTT = DOU
+                     ELSE
+                        NEWFTT = WBEGIN + NEWFST - 1
+                     ENDIF
+                  ENDIF
+
+                  IF( NEWSIZ.GT.1) THEN
+*
+*                    Current child is not a singleton but a cluster.
+*                    Compute and store new representation of child.
+*
+*
+*                    Compute left and right cluster gap.
+*
+*                    LGAP and RGAP are not computed from WORK because
+*                    the eigenvalue approximations may stem from RRRs
+*                    different shifts. However, W hold all eigenvalues
+*                    of the unshifted matrix. Still, the entries in WGAP
+*                    have to be computed from WORK since the entries
+*                    in W might be of the same order so that gaps are not
+*                    exhibited correctly for very close eigenvalues.
+                     IF( NEWFST.EQ.1 ) THEN
+                        LGAP = MAX( ZERO,
+     $                       W(WBEGIN)-WERR(WBEGIN) - VL )
+                    ELSE
+                        LGAP = WGAP( WBEGIN+NEWFST-2 )
+                     ENDIF
+                     RGAP = WGAP( WBEGIN+NEWLST-1 )
+*
+*                    Compute left- and rightmost eigenvalue of child
+*                    to high precision in order to shift as close
+*                    as possible and obtain as large relative gaps
+*                    as possible
+*
+                     DO 55 K =1,2
+                        IF(K.EQ.1) THEN
+                           P = INDEXW( WBEGIN-1+NEWFST )
+                        ELSE
+                           P = INDEXW( WBEGIN-1+NEWLST )
+                        ENDIF
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL DLARRB( IN, D(IBEGIN),
+     $                       WORK( INDLLD+IBEGIN-1 ),P,P,
+     $                       RQTOL, RQTOL, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       IN, IINFO )
+ 55                  CONTINUE
+*
+                     IF((WBEGIN+NEWLST-1.LT.DOL).OR.
+     $                  (WBEGIN+NEWFST-1.GT.DOU)) THEN
+*                       if the cluster contains no desired eigenvalues
+*                       skip the computation of that branch of the rep. tree
+*
+*                       We could skip before the refinement of the extremal
+*                       eigenvalues of the child, but then the representation
+*                       tree could be different from the one when nothing is
+*                       skipped. For this reason we skip at this place.
+                        IDONE = IDONE + NEWLST - NEWFST + 1
+                        GOTO 139
+                     ENDIF
+*
+*                    Compute RRR of child cluster.
+*                    Note that the new RRR is stored in Z
+*
+C                    DLARRF needs LWORK = 2*N
+                     CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
+     $                         WORK(INDLD+IBEGIN-1),
+     $                         NEWFST, NEWLST, WORK(WBEGIN),
+     $                         WGAP(WBEGIN), WERR(WBEGIN),
+     $                         SPDIAM, LGAP, RGAP, PIVMIN, TAU,
+     $                         WORK( INDIN1 ), WORK( INDIN2 ),
+     $                         WORK( INDWRK ), IINFO )
+*                    In the complex case, DLARRF cannot write
+*                    the new RRR directly into Z and needs an intermediate
+*                    workspace
+                     DO 56 K = 1, IN-1
+                        Z( IBEGIN+K-1, NEWFTT ) =
+     $                     DCMPLX( WORK( INDIN1+K-1 ), ZERO )
+                        Z( IBEGIN+K-1, NEWFTT+1 ) =
+     $                     DCMPLX( WORK( INDIN2+K-1 ), ZERO )
+   56                CONTINUE
+                     Z( IEND, NEWFTT ) =
+     $                  DCMPLX( WORK( INDIN1+IN-1 ), ZERO )
+                     IF( IINFO.EQ.0 ) THEN
+*                       a new RRR for the cluster was found by DLARRF
+*                       update shift and store it
+                        SSIGMA = SIGMA + TAU
+                        Z( IEND, NEWFTT+1 ) = DCMPLX( SSIGMA, ZERO )
+*                       WORK() are the midpoints and WERR() the semi-width
+*                       Note that the entries in W are unchanged.
+                        DO 116 K = NEWFST, NEWLST
+                           FUDGE =
+     $                          THREE*EPS*ABS(WORK(WBEGIN+K-1))
+                           WORK( WBEGIN + K - 1 ) =
+     $                          WORK( WBEGIN + K - 1) - TAU
+                           FUDGE = FUDGE +
+     $                          FOUR*EPS*ABS(WORK(WBEGIN+K-1))
+*                          Fudge errors
+                           WERR( WBEGIN + K - 1 ) =
+     $                          WERR( WBEGIN + K - 1 ) + FUDGE
+*                          Gaps are not fudged. Provided that WERR is small
+*                          when eigenvalues are close, a zero gap indicates
+*                          that a new representation is needed for resolving
+*                          the cluster. A fudge could lead to a wrong decision
+*                          of judging eigenvalues 'separated' which in
+*                          reality are not. This could have a negative impact
+*                          on the orthogonality of the computed eigenvectors.
+ 116                    CONTINUE
+
+                        NCLUS = NCLUS + 1
+                        K = NEWCLS + 2*NCLUS
+                        IWORK( K-1 ) = NEWFST
+                        IWORK( K ) = NEWLST
+                     ELSE
+                        INFO = -2
+                        RETURN
+                     ENDIF
+                  ELSE
+*
+*                    Compute eigenvector of singleton
+*
+                     ITER = 0
+*
+                     TOL = FOUR * LOG(DBLE(IN)) * EPS
+*
+                     K = NEWFST
+                     WINDEX = WBEGIN + K - 1
+                     WINDMN = MAX(WINDEX - 1,1)
+                     WINDPL = MIN(WINDEX + 1,M)
+                     LAMBDA = WORK( WINDEX )
+                     DONE = DONE + 1
+*                    Check if eigenvector computation is to be skipped
+                     IF((WINDEX.LT.DOL).OR.
+     $                  (WINDEX.GT.DOU)) THEN
+                        ESKIP = .TRUE.
+                        GOTO 125
+                     ELSE
+                        ESKIP = .FALSE.
+                     ENDIF
+                     LEFT = WORK( WINDEX ) - WERR( WINDEX )
+                     RIGHT = WORK( WINDEX ) + WERR( WINDEX )
+                     INDEIG = INDEXW( WINDEX )
+*                    Note that since we compute the eigenpairs for a child,
+*                    all eigenvalue approximations are w.r.t the same shift.
+*                    In this case, the entries in WORK should be used for
+*                    computing the gaps since they exhibit even very small
+*                    differences in the eigenvalues, as opposed to the
+*                    entries in W which might "look" the same.
+
+                     IF( K .EQ. 1) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VL, the formula
+*                       LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
+*                       can lead to an overestimation of the left gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small left gap.
+                        LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        LGAP = WGAP(WINDMN)
+                     ENDIF
+                     IF( K .EQ. IM) THEN
+*                       In the case RANGE='I' and with not much initial
+*                       accuracy in LAMBDA and VU, the formula
+*                       can lead to an overestimation of the right gap and
+*                       thus to inadequately early RQI 'convergence'.
+*                       Prevent this by forcing a small right gap.
+                        RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+                     ELSE
+                        RGAP = WGAP(WINDEX)
+                     ENDIF
+                     GAP = MIN( LGAP, RGAP )
+                     IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
+*                       The eigenvector support can become wrong
+*                       because significant entries could be cut off due to a
+*                       large GAPTOL parameter in LAR1V. Prevent this.
+                        GAPTOL = ZERO
+                     ELSE
+                        GAPTOL = GAP * EPS
+                     ENDIF
+                     ISUPMN = IN
+                     ISUPMX = 1
+*                    Update WGAP so that it holds the minimum gap
+*                    to the left or the right. This is crucial in the
+*                    case where bisection is used to ensure that the
+*                    eigenvalue is refined up to the required precision.
+*                    The correct value is restored afterwards.
+                     SAVGAP = WGAP(WINDEX)
+                     WGAP(WINDEX) = GAP
+*                    We want to use the Rayleigh Quotient Correction
+*                    as often as possible since it converges quadratically
+*                    when we are close enough to the desired eigenvalue.
+*                    However, the Rayleigh Quotient can have the wrong sign
+*                    and lead us away from the desired eigenvalue. In this
+*                    case, the best we can do is to use bisection.
+                     USEDBS = .FALSE.
+                     USEDRQ = .FALSE.
+*                    Bisection is initially turned off unless it is forced
+                     NEEDBS =  .NOT.TRYRQC
+ 120                 CONTINUE
+*                    Check if bisection should be used to refine eigenvalue
+                     IF(NEEDBS) THEN
+*                       Take the bisection as new iterate
+                        USEDBS = .TRUE.
+                        ITMP1 = IWORK( IINDR+WINDEX )
+                        OFFSET = INDEXW( WBEGIN ) - 1
+                        CALL DLARRB( IN, D(IBEGIN),
+     $                       WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+     $                       ZERO, TWO*EPS, OFFSET,
+     $                       WORK(WBEGIN),WGAP(WBEGIN),
+     $                       WERR(WBEGIN),WORK( INDWRK ),
+     $                       IWORK( IINDWK ), PIVMIN, SPDIAM,
+     $                       ITMP1, IINFO )
+                        IF( IINFO.NE.0 ) THEN
+                           INFO = -3
+                           RETURN
+                        ENDIF
+                        LAMBDA = WORK( WINDEX )
+*                       Reset twist index from inaccurate LAMBDA to
+*                       force computation of true MINGMA
+                        IWORK( IINDR+WINDEX ) = 0
+                     ENDIF
+*                    Given LAMBDA, compute the eigenvector.
+                     CALL ZLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
+     $                    L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+     $                    WORK(INDLLD+IBEGIN-1),
+     $                    PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                    .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                    IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
+     $                    NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                     IF(ITER .EQ. 0) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ELSEIF(RESID.LT.BSTRES) THEN
+                        BSTRES = RESID
+                        BSTW = LAMBDA
+                     ENDIF
+                     ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
+                     ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
+                     ITER = ITER + 1
+
+*                    sin alpha <= |resid|/gap
+*                    Note that both the residual and the gap are
+*                    proportional to the matrix, so ||T|| doesn't play
+*                    a role in the quotient
+
+*
+*                    Convergence test for Rayleigh-Quotient iteration
+*                    (omitted when Bisection has been used)
+*
+                     IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
+     $                    RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
+     $                    THEN
+*                       We need to check that the RQCORR update doesn't
+*                       move the eigenvalue away from the desired one and
+*                       towards a neighbor. -> protection with bisection
+                        IF(INDEIG.LE.NEGCNT) THEN
+*                          The wanted eigenvalue lies to the left
+                           SGNDEF = -ONE
+                        ELSE
+*                          The wanted eigenvalue lies to the right
+                           SGNDEF = ONE
+                        ENDIF
+*                       We only use the RQCORR if it improves the
+*                       the iterate reasonably.
+                        IF( ( RQCORR*SGNDEF.GE.ZERO )
+     $                       .AND.( LAMBDA + RQCORR.LE. RIGHT)
+     $                       .AND.( LAMBDA + RQCORR.GE. LEFT)
+     $                       ) THEN
+                           USEDRQ = .TRUE.
+*                          Store new midpoint of bisection interval in WORK
+                           IF(SGNDEF.EQ.ONE) THEN
+*                             The current LAMBDA is on the left of the true
+*                             eigenvalue
+                              LEFT = LAMBDA
+*                             We prefer to assume that the error estimate
+*                             is correct. We could make the interval not
+*                             as a bracket but to be modified if the RQCORR
+*                             chooses to. In this case, the RIGHT side should
+*                             be modified as follows:
+*                              RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
+                           ELSE
+*                             The current LAMBDA is on the right of the true
+*                             eigenvalue
+                              RIGHT = LAMBDA
+*                             See comment about assuming the error estimate is
+*                             correct above.
+*                              LEFT = MIN(LEFT, LAMBDA + RQCORR)
+                           ENDIF
+                           WORK( WINDEX ) =
+     $                       HALF * (RIGHT + LEFT)
+*                          Take RQCORR since it has the correct sign and
+*                          improves the iterate reasonably
+                           LAMBDA = LAMBDA + RQCORR
+*                          Update width of error interval
+                           WERR( WINDEX ) =
+     $                             HALF * (RIGHT-LEFT)
+                        ELSE
+                           NEEDBS = .TRUE.
+                        ENDIF
+                        IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
+*                             The eigenvalue is computed to bisection accuracy
+*                             compute eigenvector and stop
+                           USEDBS = .TRUE.
+                           GOTO 120
+                        ELSEIF( ITER.LT.MAXITR ) THEN
+                           GOTO 120
+                        ELSEIF( ITER.EQ.MAXITR ) THEN
+                           NEEDBS = .TRUE.
+                           GOTO 120
+                        ELSE
+                           INFO = 5
+                           RETURN
+                        END IF
+                     ELSE
+                        STP2II = .FALSE.
+        IF(USEDRQ .AND. USEDBS .AND.
+     $                     BSTRES.LE.RESID) THEN
+                           LAMBDA = BSTW
+                           STP2II = .TRUE.
+                        ENDIF
+                        IF (STP2II) THEN
+*                          improve error angle by second step
+                           CALL ZLAR1V( IN, 1, IN, LAMBDA,
+     $                          D( IBEGIN ), L( IBEGIN ),
+     $                          WORK(INDLD+IBEGIN-1),
+     $                          WORK(INDLLD+IBEGIN-1),
+     $                          PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+     $                          .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+     $                          IWORK( IINDR+WINDEX ),
+     $                          ISUPPZ( 2*WINDEX-1 ),
+     $                          NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+                        ENDIF
+                        WORK( WINDEX ) = LAMBDA
+                     END IF
+*
+*                    Compute FP-vector support w.r.t. whole matrix
+*
+                     ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
+                     ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
+                     ZFROM = ISUPPZ( 2*WINDEX-1 )
+                     ZTO = ISUPPZ( 2*WINDEX )
+                     ISUPMN = ISUPMN + OLDIEN
+                     ISUPMX = ISUPMX + OLDIEN
+*                    Ensure vector is ok if support in the RQI has changed
+                     IF(ISUPMN.LT.ZFROM) THEN
+                        DO 122 II = ISUPMN,ZFROM-1
+                           Z( II, WINDEX ) = ZERO
+ 122                    CONTINUE
+                     ENDIF
+                     IF(ISUPMX.GT.ZTO) THEN
+                        DO 123 II = ZTO+1,ISUPMX
+                           Z( II, WINDEX ) = ZERO
+ 123                    CONTINUE
+                     ENDIF
+                     CALL ZDSCAL( ZTO-ZFROM+1, NRMINV,
+     $                       Z( ZFROM, WINDEX ), 1 )
+ 125                 CONTINUE
+*                    Update W
+                     W( WINDEX ) = LAMBDA+SIGMA
+*                    Recompute the gaps on the left and right
+*                    But only allow them to become larger and not
+*                    smaller (which can only happen through "bad"
+*                    cancellation and doesn't reflect the theory
+*                    where the initial gaps are underestimated due
+*                    to WERR being too crude.)
+                     IF(.NOT.ESKIP) THEN
+                        IF( K.GT.1) THEN
+                           WGAP( WINDMN ) = MAX( WGAP(WINDMN),
+     $                          W(WINDEX)-WERR(WINDEX)
+     $                          - W(WINDMN)-WERR(WINDMN) )
+                        ENDIF
+                        IF( WINDEX.LT.WEND ) THEN
+                           WGAP( WINDEX ) = MAX( SAVGAP,
+     $                          W( WINDPL )-WERR( WINDPL )
+     $                          - W( WINDEX )-WERR( WINDEX) )
+                        ENDIF
+                     ENDIF
+                     IDONE = IDONE + 1
+                  ENDIF
+*                 here ends the code for the current child
+*
+ 139              CONTINUE
+*                 Proceed to any remaining child nodes
+                  NEWFST = J + 1
+ 140           CONTINUE
+ 150        CONTINUE
+            NDEPTH = NDEPTH + 1
+            GO TO 40
+         END IF
+         IBEGIN = IEND + 1
+         WBEGIN = WEND + 1
+ 170  CONTINUE
+*
+
+      RETURN
+*
+*     End of ZLARRV
+*
+      END
diff --git a/SRC/zlartg.f b/SRC/zlartg.f
new file mode 100644
index 00000000..6d3a850e
--- /dev/null
+++ b/SRC/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/zlartv.f b/SRC/zlartv.f
new file mode 100644
index 00000000..ae910b64
--- /dev/null
+++ b/SRC/zlartv.f
@@ -0,0 +1,78 @@
+      SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCC, INCX, INCY, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * )
+      COMPLEX*16         S( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARTV applies a vector of complex plane rotations with real cosines
+*  to elements of the complex vectors x and y. For i = 1,2,...,n
+*
+*     ( x(i) ) := (        c(i)   s(i) ) ( x(i) )
+*     ( y(i) )    ( -conjg(s(i))  c(i) ) ( y(i) )
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of plane rotations to be applied.
+*
+*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)
+*          The vector x.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)
+*          The vector y.
+*
+*  INCY    (input) INTEGER
+*          The increment between elements of Y. INCY > 0.
+*
+*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+*          The cosines of the plane rotations.
+*
+*  S       (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)
+*          The sines of the plane rotations.
+*
+*  INCC    (input) INTEGER
+*          The increment between elements of C and S. INCC > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IX, IY
+      COMPLEX*16         XI, YI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IX = 1
+      IY = 1
+      IC = 1
+      DO 10 I = 1, N
+         XI = X( IX )
+         YI = Y( IY )
+         X( IX ) = C( IC )*XI + S( IC )*YI
+         Y( IY ) = C( IC )*YI - DCONJG( S( IC ) )*XI
+         IX = IX + INCX
+         IY = IY + INCY
+         IC = IC + INCC
+   10 CONTINUE
+      RETURN
+*
+*     End of ZLARTV
+*
+      END
diff --git a/SRC/zlarz.f b/SRC/zlarz.f
new file mode 100644
index 00000000..18124672
--- /dev/null
+++ b/SRC/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/zlarzb.f b/SRC/zlarzb.f
new file mode 100644
index 00000000..05d2a0e3
--- /dev/null
+++ b/SRC/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/zlarzt.f b/SRC/zlarzt.f
new file mode 100644
index 00000000..9242ed36
--- /dev/null
+++ b/SRC/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/zlascl.f b/SRC/zlascl.f
new file mode 100644
index 00000000..cb296405
--- /dev/null
+++ b/SRC/zlascl.f
@@ -0,0 +1,283 @@
+      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, DISNAN
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH, DISNAN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
+         INFO = -4
+      ELSE IF( DISNAN(CTO) ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( '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
+      IF( CFROM1.EQ.CFROMC ) THEN
+!        CFROMC is an inf.  Multiply by a correctly signed zero for
+!        finite CTOC, or a NaN if CTOC is infinite.
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+         CTO1 = CTOC
+      ELSE
+         CTO1 = CTOC / BIGNUM
+         IF( CTO1.EQ.CTOC ) THEN
+!           CTOC is either 0 or an inf.  In both cases, CTOC itself
+!           serves as the correct multiplication factor.
+            MUL = CTOC
+            DONE = .TRUE.
+            CFROMC = ONE
+         ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+            MUL = SMLNUM
+            DONE = .FALSE.
+            CFROMC = CFROM1
+         ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+            MUL = BIGNUM
+            DONE = .FALSE.
+            CTOC = CTO1
+         ELSE
+            MUL = CTOC / CFROMC
+            DONE = .TRUE.
+         END IF
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of ZLASCL
+*
+      END
diff --git a/SRC/zlaset.f b/SRC/zlaset.f
new file mode 100644
index 00000000..88fc21b2
--- /dev/null
+++ b/SRC/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/zlasr.f b/SRC/zlasr.f
new file mode 100644
index 00000000..507a20c4
--- /dev/null
+++ b/SRC/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/zlassq.f b/SRC/zlassq.f
new file mode 100644
index 00000000..a209984b
--- /dev/null
+++ b/SRC/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/zlaswp.f b/SRC/zlaswp.f
new file mode 100644
index 00000000..8b07e48b
--- /dev/null
+++ b/SRC/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/zlasyf.f b/SRC/zlasyf.f
new file mode 100644
index 00000000..429131ff
--- /dev/null
+++ b/SRC/zlasyf.f
@@ -0,0 +1,597 @@
+      SUBROUTINE ZLASYF( 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( * )
+      COMPLEX*16         A( LDA, * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASYF computes a partial factorization of a complex 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.
+*  Note that U' denotes the transpose of U.
+*
+*  ZLASYF is an auxiliary routine called by ZSYTRF. 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) COMPLEX*16 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) COMPLEX*16 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 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+     $                   KSTEP, KW
+      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, ROWMAX
+      COMPLEX*16         D11, D21, D22, R1, T, Z
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      EXTERNAL           LSAME, IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+*     ..
+*     .. 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 ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+         IF( K.LT.N )
+     $      CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+     $                  W( K, KW+1 ), LDW, CONE, 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 = CABS1( 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 = IZAMAX( K-1, W( 1, KW ), 1 )
+            COLMAX = CABS1( 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 ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+               CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+     $                     W( IMAX+1, KW-1 ), 1 )
+               IF( K.LT.N )
+     $            CALL ZGEMV( 'No transpose', K, N-K, -CONE,
+     $                        A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+     $                        CONE, 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 + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, KW-1 ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 ZCOPY( 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 ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+*              Interchange rows KK and KP in last KK columns of A and W
+*
+               CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+               CALL ZSWAP( 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 ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+               R1 = CONE / A( K, K )
+               CALL ZSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+     $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+     $                     A( J, JJ ), 1 )
+   40       CONTINUE
+*
+*           Update the rectangular superdiagonal block
+*
+            CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+     $                  -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+     $                  CONE, 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 ZSWAP( 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 ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+         CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
+     $               W( K, 1 ), LDW, CONE, 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 = CABS1( 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 + IZAMAX( N-K, W( K+1, K ), 1 )
+            COLMAX = CABS1( 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 ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+               CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
+     $                     1 )
+               CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+     $                     LDA, W( IMAX, 1 ), LDW, CONE, 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 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
+               ROWMAX = CABS1( W( JMAX, K+1 ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 ZCOPY( 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 ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+               CALL ZCOPY( 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 ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+               CALL ZSWAP( 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 ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+               IF( K.LT.N ) THEN
+                  R1 = CONE / A( K, K )
+                  CALL ZSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+     $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+     $                     A( JJ, JJ ), 1 )
+  100       CONTINUE
+*
+*           Update the rectangular subdiagonal block
+*
+            IF( J+JB.LE.N )
+     $         CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+     $                     K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+     $                     LDW, CONE, 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 ZSWAP( 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 ZLASYF
+*
+      END
diff --git a/SRC/zlatbs.f b/SRC/zlatbs.f
new file mode 100644
index 00000000..5dccd835
--- /dev/null
+++ b/SRC/zlatbs.f
@@ -0,0 +1,908 @@
+      SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, 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, KD, LDAB, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   CNORM( * )
+      COMPLEX*16         AB( LDAB, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLATBS 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, where A is an upper or lower
+*  triangular band matrix.  Here 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 ZTBSV 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.
+*
+*  KD      (input) INTEGER
+*          The number of subdiagonals or superdiagonals in the
+*          triangular matrix A.  KD >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first KD+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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, ZTBSV
+*  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 ZTBSV 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 ZTBSV 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, JLEN, MAIND
+      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, ZTBSV
+*     ..
+*     .. 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( KD.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLATBS', -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
+               JLEN = MIN( KD, J-1 )
+               CNORM( J ) = DZASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N
+               JLEN = MIN( KD, N-J )
+               IF( JLEN.GT.0 ) THEN
+                  CNORM( J ) = DZASUM( JLEN, AB( 2, J ), 1 )
+               ELSE
+                  CNORM( J ) = ZERO
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM/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 ZTBSV 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
+            MAIND = KD + 1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+            MAIND = 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 = AB( MAIND, 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
+            MAIND = KD + 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+            MAIND = 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 = AB( MAIND, 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 ZTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, 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 = AB( MAIND, 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(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
+*                                             x(j)* A(max(1,j-kd):j-1,j)
+*
+                     JLEN = MIN( KD, J-1 )
+                     CALL ZAXPY( JLEN, -X( J )*TSCAL,
+     $                           AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 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:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
+*                                          x(j) * A(j+1:min(j+kd,n),j)
+*
+                  JLEN = MIN( KD, N-J )
+                  IF( JLEN.GT.0 )
+     $               CALL ZAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
+     $                           X( J+1 ), 1 )
+                  I = J + IZAMAX( N-J, X( J+1 ), 1 )
+                  XMAX = CABS1( X( I ) )
+               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 = AB( MAIND, 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
+                     JLEN = MIN( KD, J-1 )
+                     CSUMJ = ZDOTU( JLEN, AB( KD+1-JLEN, J ), 1,
+     $                       X( J-JLEN ), 1 )
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     IF( JLEN.GT.1 )
+     $                  CSUMJ = ZDOTU( JLEN, AB( 2, J ), 1, X( J+1 ),
+     $                          1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     DO 130 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
+     $                          X( J-JLEN-1+I )
+  130                CONTINUE
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     DO 140 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( AB( I+1, J )*USCAL )*X( J+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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AB( MAIND, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 160
+                  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/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( AB( MAIND, 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
+                     JLEN = MIN( KD, J-1 )
+                     CSUMJ = ZDOTC( JLEN, AB( KD+1-JLEN, J ), 1,
+     $                       X( J-JLEN ), 1 )
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     IF( JLEN.GT.1 )
+     $                  CSUMJ = ZDOTC( JLEN, AB( 2, J ), 1, X( J+1 ),
+     $                          1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     JLEN = MIN( KD, J-1 )
+                     DO 180 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( DCONJG( AB( KD+I-JLEN, J ) )*
+     $                          USCAL )*X( J-JLEN-1+I )
+  180                CONTINUE
+                  ELSE
+                     JLEN = MIN( KD, N-J )
+                     DO 190 I = 1, JLEN
+                        CSUMJ = CSUMJ + ( DCONJG( AB( I+1, J ) )*USCAL )
+     $                          *X( J+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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = DCONJG( AB( MAIND, J ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 210
+                  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/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 ZLATBS
+*
+      END
diff --git a/SRC/zlatdf.f b/SRC/zlatdf.f
new file mode 100644
index 00000000..d637b8f1
--- /dev/null
+++ b/SRC/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/zlatps.f b/SRC/zlatps.f
new file mode 100644
index 00000000..5092d603
--- /dev/null
+++ b/SRC/zlatps.f
@@ -0,0 +1,894 @@
+      SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, 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, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   CNORM( * )
+      COMPLEX*16         AP( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLATPS 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, where A is an upper or lower
+*  triangular matrix stored in packed form.  Here 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 ZTPSV 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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  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, ZTPSV
+*  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 ZTPSV 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 ZTPSV 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, IP, J, JFIRST, JINC, JLAST, JLEN
+      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, ZTPSV
+*     ..
+*     .. 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
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLATPS', -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.
+*
+            IP = 1
+            DO 10 J = 1, N
+               CNORM( J ) = DZASUM( J-1, AP( IP ), 1 )
+               IP = IP + J
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            IP = 1
+            DO 20 J = 1, N - 1
+               CNORM( J ) = DZASUM( N-J, AP( IP+1 ), 1 )
+               IP = IP + N - J + 1
+   20       CONTINUE
+            CNORM( N ) = ZERO
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM/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 ZTPSV 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
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = N
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 60
+*
+               TJJS = AP( IP )
+               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
+               IP = IP + JINC*JLEN
+               JLEN = JLEN - 1
+   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
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            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 = AP( IP )
+               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
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+   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 ZTPSV( UPLO, TRANS, DIAG, N, AP, 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
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            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 = AP( IP )*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, AP( IP-J+1 ), 1, X,
+     $                           1 )
+                     I = IZAMAX( J-1, X, 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+                  IP = IP - J
+               ELSE
+                  IF( J.LT.N ) THEN
+*
+*                    Compute the update
+*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+                     CALL ZAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + IZAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+                  IP = IP + N - J + 1
+               END IF
+  120       CONTINUE
+*
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Solve A**T * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            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 = AP( IP )*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, AP( IP-J+1 ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = ZDOTU( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 130 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( AP( IP-J+I )*USCAL )*X( I )
+  130                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 140 I = 1, N - J
+                        CSUMJ = CSUMJ + ( AP( IP+I )*USCAL )*X( J+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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = AP( IP )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 160
+                  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/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 ) ) )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+  170       CONTINUE
+*
+         ELSE
+*
+*           Solve A**H * x = b
+*
+            IP = JFIRST*( JFIRST+1 ) / 2
+            JLEN = 1
+            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( AP( IP ) )*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, AP( IP-J+1 ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = ZDOTC( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 180 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( DCONJG( AP( IP-J+I ) )*USCAL )
+     $                          *X( I )
+  180                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 190 I = 1, N - J
+                        CSUMJ = CSUMJ + ( DCONJG( AP( IP+I ) )*USCAL )*
+     $                          X( J+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
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                     TJJS = DCONJG( AP( IP ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 210
+                  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/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 ) ) )
+               JLEN = JLEN + 1
+               IP = IP + JINC*JLEN
+  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 ZLATPS
+*
+      END
diff --git a/SRC/zlatrd.f b/SRC/zlatrd.f
new file mode 100644
index 00000000..5fef7b5c
--- /dev/null
+++ b/SRC/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/zlatrs.f b/SRC/zlatrs.f
new file mode 100644
index 00000000..7466096c
--- /dev/null
+++ b/SRC/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/zlatrz.f b/SRC/zlatrz.f
new file mode 100644
index 00000000..09af735a
--- /dev/null
+++ b/SRC/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, ZLARFP, 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 ZLARFP( 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/zlatzm.f b/SRC/zlatzm.f
new file mode 100644
index 00000000..1865f773
--- /dev/null
+++ b/SRC/zlatzm.f
@@ -0,0 +1,146 @@
+      SUBROUTINE ZLATZM( 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
+      COMPLEX*16         TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine ZUNMRZ.
+*
+*  ZLATZM applies a Householder matrix generated by ZTZRQF 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) COMPLEX*16 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) COMPLEX*16
+*          The value tau in the representation of P.
+*
+*  C1      (input/output) COMPLEX*16 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) COMPLEX*16 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 >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                      (N) if SIDE = 'L'
+*                      (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           ZAXPY, ZCOPY, ZGEMV, ZGERC, ZGERU, ZLACGV
+*     ..
+*     .. 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 :=  conjg( C1 + v' * C2 )
+*
+         CALL ZCOPY( N, C1, LDC, WORK, 1 )
+         CALL ZLACGV( N, WORK, 1 )
+         CALL ZGEMV( 'Conjugate transpose', M-1, N, ONE, C2, LDC, V,
+     $               INCV, ONE, WORK, 1 )
+*
+*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
+*        [ C2 ]    [ C2 ]        [ v ]
+*
+         CALL ZLACGV( N, WORK, 1 )
+         CALL ZAXPY( N, -TAU, WORK, 1, C1, LDC )
+         CALL ZGERU( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
+*
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        w := C1 + C2 * v
+*
+         CALL ZCOPY( M, C1, 1, WORK, 1 )
+         CALL ZGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
+     $               WORK, 1 )
+*
+*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
+*
+         CALL ZAXPY( M, -TAU, WORK, 1, C1, 1 )
+         CALL ZGERC( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
+      END IF
+*
+      RETURN
+*
+*     End of ZLATZM
+*
+      END
diff --git a/SRC/zlauu2.f b/SRC/zlauu2.f
new file mode 100644
index 00000000..03e95ecc
--- /dev/null
+++ b/SRC/zlauu2.f
@@ -0,0 +1,143 @@
+      SUBROUTINE ZLAUU2( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAUU2 computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the unblocked form of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZGEMV, ZLACGV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, 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( 'ZLAUU2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the product U * U'.
+*
+         DO 10 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I, I+1 ), LDA,
+     $                     A( I, I+1 ), LDA ) )
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+               CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, DCMPLX( AII ),
+     $                     A( 1, I ), 1 )
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+            ELSE
+               CALL ZDSCAL( I, AII, A( 1, I ), 1 )
+            END IF
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product L' * L.
+*
+         DO 20 I = 1, N
+            AII = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I+1, I ), 1,
+     $                     A( I+1, I ), 1 ) )
+               CALL ZLACGV( I-1, A( I, 1 ), LDA )
+               CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
+     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1,
+     $                     DCMPLX( AII ), A( I, 1 ), LDA )
+               CALL ZLACGV( I-1, A( I, 1 ), LDA )
+            ELSE
+               CALL ZDSCAL( I, AII, A( I, 1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLAUU2
+*
+      END
diff --git a/SRC/zlauum.f b/SRC/zlauum.f
new file mode 100644
index 00000000..d408bbcc
--- /dev/null
+++ b/SRC/zlauum.f
@@ -0,0 +1,160 @@
+      SUBROUTINE ZLAUUM( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAUUM computes the product U * U' or L' * L, where the triangular
+*  factor U or L is stored in the upper or lower triangular part of
+*  the array A.
+*
+*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+*  overwriting the factor U in A.
+*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+*  overwriting the factor L in A.
+*
+*  This is the blocked form of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the triangular factor stored in the array A
+*          is upper or lower triangular:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the triangular factor U or L.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the triangular factor U or L.
+*          On exit, if UPLO = 'U', the upper triangle of A is
+*          overwritten with the upper triangle of the product U * U';
+*          if UPLO = 'L', the lower triangle of A is overwritten with
+*          the lower triangle of the product 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMM, ZHERK, ZLAUU2, ZTRMM
+*     ..
+*     .. 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( 'ZLAUUM', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'ZLAUUM', UPLO, N, -1, -1, -1 )
+*
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZLAUU2( UPLO, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( UPPER ) THEN
+*
+*           Compute the product U * U'.
+*
+            DO 10 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Non-unit', I-1, IB, CONE, A( I, I ), LDA,
+     $                     A( 1, I ), LDA )
+               CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                        I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ),
+     $                        LDA, A( I, I+IB ), LDA, CONE, A( 1, I ),
+     $                        LDA )
+                  CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1,
+     $                        ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
+     $                        LDA )
+               END IF
+   10       CONTINUE
+         ELSE
+*
+*           Compute the product L' * L.
+*
+            DO 20 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+               CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose',
+     $                     'Non-unit', IB, I-1, CONE, A( I, I ), LDA,
+     $                     A( I, 1 ), LDA )
+               CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
+               IF( I+IB.LE.N ) THEN
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', IB,
+     $                        I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA,
+     $                        A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA )
+                  CALL ZHERK( 'Lower', 'Conjugate transpose', IB,
+     $                        N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE,
+     $                        A( I, I ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLAUUM
+*
+      END
diff --git a/SRC/zpbcon.f b/SRC/zpbcon.f
new file mode 100644
index 00000000..004cffc6
--- /dev/null
+++ b/SRC/zpbcon.f
@@ -0,0 +1,198 @@
+      SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, 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          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite band matrix using
+*  the Cholesky factorization A = U**H*U or A = L*L**H computed by
+*  ZPBTRF.
+*
+*  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 triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          The 1-norm (or infinity-norm) of the Hermitian band 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) 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
+*
+*  =====================================================================
+*
+*     .. 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
+      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, ZLATBS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL ZLATBS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, KD, AB, LDAB, WORK, SCALEL, RWORK,
+     $                   INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL ZLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEU, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL ZLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   KD, AB, LDAB, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL ZLATBS( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, KD, AB, LDAB, WORK, SCALEU, RWORK,
+     $                   INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         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 ZPBCON
+*
+      END
diff --git a/SRC/zpbequ.f b/SRC/zpbequ.f
new file mode 100644
index 00000000..dd8bc9d3
--- /dev/null
+++ b/SRC/zpbequ.f
@@ -0,0 +1,167 @@
+      SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBEQU computes row and column scalings intended to equilibrate a
+*  Hermitian positive definite band matrix A and reduce its condition
+*  number (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular of A is stored;
+*          = 'L':  Lower triangular of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangle of the Hermitian band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB     (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) DOUBLE PRECISION
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, J
+      DOUBLE PRECISION   SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+         J = KD + 1
+      ELSE
+         J = 1
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = DBLE( AB( J, 1 ) )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      DO 10 I = 2, N
+         S( I ) = DBLE( AB( J, I ) )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of ZPBEQU
+*
+      END
diff --git a/SRC/zpbrfs.f b/SRC/zpbrfs.f
new file mode 100644
index 00000000..7120ae12
--- /dev/null
+++ b/SRC/zpbrfs.f
@@ -0,0 +1,346 @@
+      SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
+     $                   LDB, X, LDX, FERR, BERR, 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          UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite
+*  and banded, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
+*          The upper or lower triangle of the Hermitian band matrix A,
+*          stored in the first KD+1 rows of the array.  The j-th column
+*          of A is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H of the band matrix A as computed by
+*          ZPBTRF, in the same storage format as A (see AB).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZPBTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, L, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZHBMV, ZLACN2, ZPBTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = MIN( N+1, 2*KD+2 )
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZHBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
+     $               WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               L = KD + 1 - K
+               DO 40 I = MAX( 1, K-KD ), K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AB( L+I, K ) )*XK
+                  S = S + CABS1( AB( L+I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( AB( KD+1, K ) ) )*
+     $                      XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( AB( 1, K ) ) )*XK
+               L = 1 - K
+               DO 60 I = K + 1, MIN( N, K+KD )
+                  RWORK( I ) = RWORK( I ) + CABS1( AB( L+I, K ) )*XK
+                  S = S + CABS1( AB( L+I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZPBRFS
+*
+      END
diff --git a/SRC/zpbstf.f b/SRC/zpbstf.f
new file mode 100644
index 00000000..54f60507
--- /dev/null
+++ b/SRC/zpbstf.f
@@ -0,0 +1,263 @@
+      SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBSTF computes a split Cholesky factorization of a complex
+*  Hermitian positive definite band matrix A.
+*
+*  This routine is designed to be used in conjunction with ZHBGST.
+*
+*  The factorization has the form  A = S**H*S  where S is a band matrix
+*  of the same bandwidth as A and the following structure:
+*
+*    S = ( U    )
+*        ( M  L )
+*
+*  where U is upper triangular of order m = (n+kd)/2, and L is lower
+*  triangular of order n-m.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first kd+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the factor S from the split Cholesky
+*          factorization A = S**H*S. See Further Details.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, the factorization could not be completed,
+*               because the updated element a(i,i) was negative; the
+*               matrix A is not positive definite.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 7, KD = 2:
+*
+*  S = ( s11  s12  s13                     )
+*      (      s22  s23  s24                )
+*      (           s33  s34                )
+*      (                s44                )
+*      (           s53  s54  s55           )
+*      (                s64  s65  s66      )
+*      (                     s75  s76  s77 )
+*
+*  If UPLO = 'U', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53' s64' s75'
+*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54' s65' s76'
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*
+*  If UPLO = 'L', the array AB holds:
+*
+*  on entry:                          on exit:
+*
+*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
+*  a21  a32  a43  a54  a65  a76   *   s12' s23' s34' s54  s65  s76   *
+*  a31  a42  a53  a64  a64   *    *   s13' s24' s53  s64  s75   *    *
+*
+*  Array elements marked * are not used by the routine; s12' denotes
+*  conjg(s12); the diagonal elements of S are real.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KM, M
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZHER, ZLACGV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBSTF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+*     Set the splitting point m.
+*
+      M = ( N+KD ) / 2
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
+*
+         DO 10 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( AB( KD+1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( KD+1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th column and update the
+*           the leading submatrix within the band.
+*
+            CALL ZDSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
+            CALL ZHER( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
+     $                 AB( KD+1, J-KM ), KLD )
+   10    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**H*U.
+*
+         DO 20 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( AB( KD+1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( KD+1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL ZDSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL ZLACGV( KM, AB( KD, J+1 ), KLD )
+               CALL ZHER( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+               CALL ZLACGV( KM, AB( KD, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m).
+*
+         DO 30 J = N, M + 1, -1
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( AB( 1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( 1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( J-1, KD )
+*
+*           Compute elements j-km:j-1 of the j-th row and update the
+*           trailing submatrix within the band.
+*
+            CALL ZDSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
+            CALL ZLACGV( KM, AB( KM+1, J-KM ), KLD )
+            CALL ZHER( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
+     $                 AB( 1, J-KM ), KLD )
+            CALL ZLACGV( KM, AB( KM+1, J-KM ), KLD )
+   30    CONTINUE
+*
+*        Factorize the updated submatrix A(1:m,1:m) as U**H*U.
+*
+         DO 40 J = 1, M
+*
+*           Compute s(j,j) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( AB( 1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( 1, J ) = AJJ
+               GO TO 50
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+            KM = MIN( KD, M-J )
+*
+*           Compute elements j+1:j+km of the j-th column and update the
+*           trailing submatrix within the band.
+*
+            IF( KM.GT.0 ) THEN
+               CALL ZDSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
+               CALL ZHER( 'Lower', KM, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+   50 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of ZPBSTF
+*
+      END
diff --git a/SRC/zpbsv.f b/SRC/zpbsv.f
new file mode 100644
index 00000000..83ca7094
--- /dev/null
+++ b/SRC/zpbsv.f
@@ -0,0 +1,151 @@
+      SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**H * U,  if UPLO = 'U', or
+*     A = L * L**H,  if UPLO = 'L',
+*  where U is an upper triangular band matrix, and L is a lower
+*  triangular band matrix, with the same number of superdiagonals or
+*  subdiagonals as A.  The factored form of A is then used to solve the
+*  system of equations A * X = B.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**H*U or A = L*L**H of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) COMPLEX*16 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZPBTRF, ZPBTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of ZPBSV
+*
+      END
diff --git a/SRC/zpbsvx.f b/SRC/zpbsvx.f
new file mode 100644
index 00000000..6fb5d36b
--- /dev/null
+++ b/SRC/zpbsvx.f
@@ -0,0 +1,421 @@
+      SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
+     $                   EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * ), S( * )
+      COMPLEX*16         AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
+*  compute the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite band matrix and X
+*  and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**H * U,  if UPLO = 'U', or
+*        A = L * L**H,  if UPLO = 'L',
+*     where U is an upper triangular band matrix, and L is a lower
+*     triangular band matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFB contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AB and AFB will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFB and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFB and factored.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right-hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array, except
+*          if FACT = 'F' and EQUED = 'Y', then A must contain the
+*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A
+*          is stored in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
+*          See below for further details.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array A.  LDAB >= KD+1.
+*
+*  AFB     (input or output) COMPLEX*16 array, dimension (LDAFB,N)
+*          If FACT = 'F', then AFB is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the band matrix
+*          A, in the same storage format as A (see AB).  If EQUED = 'Y',
+*          then AFB is the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H.
+*
+*          If FACT = 'E', then AFB is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the equilibrated
+*          matrix A (see the description of A for the form of the
+*          equilibrated matrix).
+*
+*  LDAFB   (input) INTEGER
+*          The leading dimension of the array AFB.  LDAFB >= KD+1.
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  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) 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
+*          > 0: if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11  a12  a13
+*          a22  a23  a24
+*               a33  a34  a35
+*                    a44  a45  a46
+*                         a55  a56
+*     (aij=conjg(aji))         a66
+*
+*  Band storage of the upper triangle of A:
+*
+*      *    *   a13  a24  a35  a46
+*      *   a12  a23  a34  a45  a56
+*     a11  a22  a33  a44  a55  a66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*     a11  a22  a33  a44  a55  a66
+*     a21  a32  a43  a54  a65   *
+*     a31  a42  a53  a64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU, UPPER
+      INTEGER            I, INFEQU, J, J1, J2
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHB
+      EXTERNAL           LSAME, DLAMCH, ZLANHB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZLACPY, ZLAQHB, ZPBCON, ZPBEQU,
+     $                   ZPBRFS, ZPBTRF, ZPBTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      ELSE IF( LDAFB.LT.KD+1 ) THEN
+         INFO = -9
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -10
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -11
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -13
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -15
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         IF( UPPER ) THEN
+            DO 40 J = 1, N
+               J1 = MAX( J-KD, 1 )
+               CALL ZCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
+     $                     AFB( KD+1-J+J1, J ), 1 )
+   40       CONTINUE
+         ELSE
+            DO 50 J = 1, N
+               J2 = MIN( J+KD, N )
+               CALL ZCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
+   50       CONTINUE
+         END IF
+*
+         CALL ZPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANHB( '1', UPLO, N, KD, AB, LDAB, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, RWORK,
+     $             INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 70 J = 1, NRHS
+            DO 60 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   60       CONTINUE
+   70    CONTINUE
+         DO 80 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   80    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZPBSVX
+*
+      END
diff --git a/SRC/zpbtf2.f b/SRC/zpbtf2.f
new file mode 100644
index 00000000..13b58a8c
--- /dev/null
+++ b/SRC/zpbtf2.f
@@ -0,0 +1,200 @@
+      SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBTF2 computes the Cholesky factorization of a complex Hermitian
+*  positive definite band 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, U' is the conjugate transpose
+*  of U, 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.
+*
+*  KD      (input) INTEGER
+*          The number of super-diagonals of the matrix A if UPLO = 'U',
+*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U'*U or A = L*L' of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  The band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, KLD, KN
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZHER, ZLACGV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      KLD = MAX( 1, LDAB-1 )
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         DO 10 J = 1, N
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( AB( KD+1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( KD+1, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( KD+1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of row J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL ZDSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
+               CALL ZLACGV( KN, AB( KD, J+1 ), KLD )
+               CALL ZHER( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
+     $                    AB( KD+1, J+1 ), KLD )
+               CALL ZLACGV( KN, AB( KD, J+1 ), KLD )
+            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( AB( 1, J ) )
+            IF( AJJ.LE.ZERO ) THEN
+               AB( 1, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            AB( 1, J ) = AJJ
+*
+*           Compute elements J+1:J+KN of column J and update the
+*           trailing submatrix within the band.
+*
+            KN = MIN( KD, N-J )
+            IF( KN.GT.0 ) THEN
+               CALL ZDSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
+               CALL ZHER( 'Lower', KN, -ONE, AB( 2, J ), 1,
+     $                    AB( 1, J+1 ), KLD )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+   30 CONTINUE
+      INFO = J
+      RETURN
+*
+*     End of ZPBTF2
+*
+      END
diff --git a/SRC/zpbtrf.f b/SRC/zpbtrf.f
new file mode 100644
index 00000000..18abd23b
--- /dev/null
+++ b/SRC/zpbtrf.f
@@ -0,0 +1,371 @@
+      SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KD, LDAB, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AB( LDAB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBTRF computes the Cholesky factorization of a complex Hermitian
+*  positive definite band 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.
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
+*          On entry, the upper or lower triangle of the Hermitian band
+*          matrix A, stored in the first KD+1 rows of the array.  The
+*          j-th column of A is stored in the j-th column of the array AB
+*          as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**H*U or A = L*L**H of the band
+*          matrix A, in the same storage format as A.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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 band storage scheme is illustrated by the following example, when
+*  N = 6, KD = 2, and UPLO = 'U':
+*
+*  On entry:                       On exit:
+*
+*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
+*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
+*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
+*
+*  Similarly, if UPLO = 'L' the format of A is as follows:
+*
+*  On entry:                       On exit:
+*
+*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
+*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
+*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
+*
+*  Array elements marked * are not used by the routine.
+*
+*  Contributed by
+*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
+*
+*  =====================================================================
+*
+*     .. 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 ) )
+      INTEGER            NBMAX, LDWORK
+      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I2, I3, IB, II, J, JJ, NB
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         WORK( LDWORK, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMM, ZHERK, ZPBTF2, ZPOTF2, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
+     $    ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment
+*
+      NB = ILAENV( 1, 'ZPBTRF', UPLO, N, KD, -1, -1 )
+*
+*     The block size must not exceed the semi-bandwidth KD, and must not
+*     exceed the limit set by the size of the local array WORK.
+*
+      NB = MIN( NB, NBMAX )
+*
+      IF( NB.LE.1 .OR. NB.GT.KD ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*           Compute the Cholesky factorization of a Hermitian band
+*           matrix, given the upper triangle of the matrix in band
+*           storage.
+*
+*           Zero the upper triangle of the work array.
+*
+            DO 20 J = 1, NB
+               DO 10 I = 1, J - 1
+                  WORK( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 70 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL ZPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11   A12   A13
+*                          A22   A23
+*                                A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A12, A22 and
+*                 A23 are empty if IB = KD. The upper triangle of A13
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A12
+*
+                     CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
+     $                           'Non-unit', IB, I2, CONE,
+     $                           AB( KD+1, I ), LDAB-1,
+     $                           AB( KD+1-IB, I+IB ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL ZHERK( 'Upper', 'Conjugate transpose', I2, IB,
+     $                           -ONE, AB( KD+1-IB, I+IB ), LDAB-1, ONE,
+     $                           AB( KD+1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the lower triangle of A13 into the work array.
+*
+                     DO 40 JJ = 1, I3
+                        DO 30 II = JJ, IB
+                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
+   30                   CONTINUE
+   40                CONTINUE
+*
+*                    Update A13 (in the work array).
+*
+                     CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
+     $                           'Non-unit', IB, I3, CONE,
+     $                           AB( KD+1, I ), LDAB-1, WORK, LDWORK )
+*
+*                    Update A23
+*
+                     IF( I2.GT.0 )
+     $                  CALL ZGEMM( 'Conjugate transpose',
+     $                              'No transpose', I2, I3, IB, -CONE,
+     $                              AB( KD+1-IB, I+IB ), LDAB-1, WORK,
+     $                              LDWORK, CONE, AB( 1+IB, I+KD ),
+     $                              LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL ZHERK( 'Upper', 'Conjugate transpose', I3, IB,
+     $                           -ONE, WORK, LDWORK, ONE,
+     $                           AB( KD+1, I+KD ), LDAB-1 )
+*
+*                    Copy the lower triangle of A13 back into place.
+*
+                     DO 60 JJ = 1, I3
+                        DO 50 II = JJ, IB
+                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
+   50                   CONTINUE
+   60                CONTINUE
+                  END IF
+               END IF
+   70       CONTINUE
+         ELSE
+*
+*           Compute the Cholesky factorization of a Hermitian band
+*           matrix, given the lower triangle of the matrix in band
+*           storage.
+*
+*           Zero the lower triangle of the work array.
+*
+            DO 90 J = 1, NB
+               DO 80 I = J + 1, NB
+                  WORK( I, J ) = ZERO
+   80          CONTINUE
+   90       CONTINUE
+*
+*           Process the band matrix one diagonal block at a time.
+*
+            DO 140 I = 1, N, NB
+               IB = MIN( NB, N-I+1 )
+*
+*              Factorize the diagonal block
+*
+               CALL ZPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
+               IF( II.NE.0 ) THEN
+                  INFO = I + II - 1
+                  GO TO 150
+               END IF
+               IF( I+IB.LE.N ) THEN
+*
+*                 Update the relevant part of the trailing submatrix.
+*                 If A11 denotes the diagonal block which has just been
+*                 factorized, then we need to update the remaining
+*                 blocks in the diagram:
+*
+*                    A11
+*                    A21   A22
+*                    A31   A32   A33
+*
+*                 The numbers of rows and columns in the partitioning
+*                 are IB, I2, I3 respectively. The blocks A21, A22 and
+*                 A32 are empty if IB = KD. The lower triangle of A31
+*                 lies outside the band.
+*
+                  I2 = MIN( KD-IB, N-I-IB+1 )
+                  I3 = MIN( IB, N-I-KD+1 )
+*
+                  IF( I2.GT.0 ) THEN
+*
+*                    Update A21
+*
+                     CALL ZTRSM( 'Right', 'Lower',
+     $                           'Conjugate transpose', 'Non-unit', I2,
+     $                           IB, CONE, AB( 1, I ), LDAB-1,
+     $                           AB( 1+IB, I ), LDAB-1 )
+*
+*                    Update A22
+*
+                     CALL ZHERK( 'Lower', 'No transpose', I2, IB, -ONE,
+     $                           AB( 1+IB, I ), LDAB-1, ONE,
+     $                           AB( 1, I+IB ), LDAB-1 )
+                  END IF
+*
+                  IF( I3.GT.0 ) THEN
+*
+*                    Copy the upper triangle of A31 into the work array.
+*
+                     DO 110 JJ = 1, IB
+                        DO 100 II = 1, MIN( JJ, I3 )
+                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
+  100                   CONTINUE
+  110                CONTINUE
+*
+*                    Update A31 (in the work array).
+*
+                     CALL ZTRSM( 'Right', 'Lower',
+     $                           'Conjugate transpose', 'Non-unit', I3,
+     $                           IB, CONE, AB( 1, I ), LDAB-1, WORK,
+     $                           LDWORK )
+*
+*                    Update A32
+*
+                     IF( I2.GT.0 )
+     $                  CALL ZGEMM( 'No transpose',
+     $                              'Conjugate transpose', I3, I2, IB,
+     $                              -CONE, WORK, LDWORK, AB( 1+IB, I ),
+     $                              LDAB-1, CONE, AB( 1+KD-IB, I+IB ),
+     $                              LDAB-1 )
+*
+*                    Update A33
+*
+                     CALL ZHERK( 'Lower', 'No transpose', I3, IB, -ONE,
+     $                           WORK, LDWORK, ONE, AB( 1, I+KD ),
+     $                           LDAB-1 )
+*
+*                    Copy the upper triangle of A31 back into place.
+*
+                     DO 130 JJ = 1, IB
+                        DO 120 II = 1, MIN( JJ, I3 )
+                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
+  120                   CONTINUE
+  130                CONTINUE
+                  END IF
+               END IF
+  140       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+  150 CONTINUE
+      RETURN
+*
+*     End of ZPBTRF
+*
+      END
diff --git a/SRC/zpbtrs.f b/SRC/zpbtrs.f
new file mode 100644
index 00000000..ccca34f0
--- /dev/null
+++ b/SRC/zpbtrs.f
@@ -0,0 +1,145 @@
+      SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPBTRS solves a system of linear equations A*X = B with a Hermitian
+*  positive definite band matrix A using the Cholesky factorization
+*  A = U**H*U or A = L*L**H computed by ZPBTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor stored in AB;
+*          = 'L':  Lower triangular factor stored in AB.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals of the matrix A if UPLO = 'U',
+*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H of the band matrix A, stored in the
+*          first KD+1 rows of the array.  The j-th column of U or L is
+*          stored in the j-th column of the array AB as follows:
+*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTBSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPBTRS', -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.
+*
+         DO 10 J = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
+     $                  KD, AB, LDAB, B( 1, J ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 J = 1, NRHS
+*
+*           Solve L*X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
+     $                  LDAB, B( 1, J ), 1 )
+*
+*           Solve L'*X = B, overwriting B with X.
+*
+            CALL ZTBSV( 'Lower', 'Conjugate transpose', 'Non-unit', N,
+     $                  KD, AB, LDAB, B( 1, J ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZPBTRS
+*
+      END
diff --git a/SRC/zpocon.f b/SRC/zpocon.f
new file mode 100644
index 00000000..af24264e
--- /dev/null
+++ b/SRC/zpocon.f
@@ -0,0 +1,184 @@
+      SUBROUTINE ZPOCON( UPLO, 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          UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite matrix using the
+*  Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by ZPOTRF.
+*
+*  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 Hermitian 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) 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
+*
+*  =====================================================================
+*
+*     .. 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
+      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
+      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( 'ZPOCON', -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 ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, A, LDA, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEU, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL ZLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, A, LDA, WORK, SCALEU, RWORK, INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         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 ZPOCON
+*
+      END
diff --git a/SRC/zpoequ.f b/SRC/zpoequ.f
new file mode 100644
index 00000000..b9594438
--- /dev/null
+++ b/SRC/zpoequ.f
@@ -0,0 +1,137 @@
+      SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOEQU computes row and column scalings intended to equilibrate a
+*  Hermitian positive definite matrix A and reduce its condition number
+*  (with respect to the two-norm).  S contains the scale factors,
+*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
+*  choice of S puts the condition number of B within a factor N of the
+*  smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The N-by-N Hermitian positive definite matrix whose scaling
+*          factors are to be computed.  Only the diagonal elements of A
+*          are referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) DOUBLE PRECISION
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   SMIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPOEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Find the minimum and maximum diagonal elements.
+*
+      S( 1 ) = DBLE( A( 1, 1 ) )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+      DO 10 I = 2, N
+         S( I ) = DBLE( A( I, I ) )
+         SMIN = MIN( SMIN, S( I ) )
+         AMAX = MAX( AMAX, S( I ) )
+   10 CONTINUE
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 20 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   20    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 30 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   30    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of ZPOEQU
+*
+      END
diff --git a/SRC/zporfs.f b/SRC/zporfs.f
new file mode 100644
index 00000000..22a52ea4
--- /dev/null
+++ b/SRC/zporfs.f
@@ -0,0 +1,337 @@
+      SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
+     $                   LDX, FERR, BERR, 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          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPORFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite,
+*  and provides error bounds and backward error estimates for the
+*  solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  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.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by ZPOTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZPOTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZHEMV, ZLACN2, ZPOTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPORFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZHEMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( A( K, K ) ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( A( K, K ) ) )*XK
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZPOTRS( UPLO, N, 1, AF, LDAF, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZPORFS
+*
+      END
diff --git a/SRC/zposv.f b/SRC/zposv.f
new file mode 100644
index 00000000..6bcaf60a
--- /dev/null
+++ b/SRC/zposv.f
@@ -0,0 +1,121 @@
+      SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, 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, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     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 a lower triangular
+*  matrix.  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) 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).
+*
+*  B       (input/output) COMPLEX*16 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZPOTRF, ZPOTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPOSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL ZPOTRF( UPLO, N, A, LDA, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of ZPOSV
+*
+      END
diff --git a/SRC/zposvx.f b/SRC/zposvx.f
new file mode 100644
index 00000000..ddf0524c
--- /dev/null
+++ b/SRC/zposvx.f
@@ -0,0 +1,376 @@
+      SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
+     $                   S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
+     $                   RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * ), S( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
+*  compute the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite 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:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U**H* U,  if UPLO = 'U', or
+*        A = L * L**H,  if UPLO = 'L',
+*     where U is an upper triangular matrix and L is a lower triangular
+*     matrix.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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 contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  A and AF will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A, except if FACT = 'F' and
+*          EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, in the same storage
+*          format as A.  If EQUED .ne. 'N', then AF is the factored form
+*          of the equilibrated matrix diag(S)*A*diag(S).
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the original
+*          matrix A.
+*
+*          If FACT = 'E', then AF is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H 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).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS righthand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  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) 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
+*          > 0: if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHE
+      EXTERNAL           LSAME, DLAMCH, ZLANHE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACPY, ZLAQHE, ZPOCON, ZPOEQU, ZPORFS,
+     $                   ZPOTRF, ZPOTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -9
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -10
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -14
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPOSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL ZPOTRF( UPLO, N, AF, LDAF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
+     $             FERR, BERR, WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZPOSVX
+*
+      END
diff --git a/SRC/zpotf2.f b/SRC/zpotf2.f
new file mode 100644
index 00000000..ca9df447
--- /dev/null
+++ b/SRC/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/zpotrf.f b/SRC/zpotrf.f
new file mode 100644
index 00000000..86772608
--- /dev/null
+++ b/SRC/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/zpotri.f b/SRC/zpotri.f
new file mode 100644
index 00000000..ab3094a6
--- /dev/null
+++ b/SRC/zpotri.f
@@ -0,0 +1,96 @@
+      SUBROUTINE ZPOTRI( 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
+*  =======
+*
+*  ZPOTRI computes the inverse of a complex Hermitian positive definite
+*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
+*  computed by ZPOTRF.
+*
+*  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 triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, as computed by
+*          ZPOTRF.
+*          On exit, the upper or lower triangle of the (Hermitian)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  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 (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLAUUM, ZTRTRI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPOTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL ZTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+*     Form inv(U)*inv(U)' or inv(L)'*inv(L).
+*
+      CALL ZLAUUM( UPLO, N, A, LDA, INFO )
+*
+      RETURN
+*
+*     End of ZPOTRI
+*
+      END
diff --git a/SRC/zpotrs.f b/SRC/zpotrs.f
new file mode 100644
index 00000000..d2136cca
--- /dev/null
+++ b/SRC/zpotrs.f
@@ -0,0 +1,132 @@
+      SUBROUTINE ZPOTRS( 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 ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOTRS solves a system of linear equations A*X = B with a Hermitian
+*  positive definite matrix A using the Cholesky factorization
+*  A = U**H*U or A = L*L**H computed by ZPOTRF.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by ZPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  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            UPPER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTRSM
+*     ..
+*     .. 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( 'ZPOTRS', -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 ZTRSM( 'Left', 'Upper', 'Conjugate transpose', 'Non-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*X = B where A = L*L'.
+*
+*        Solve L*X = B, overwriting B with X.
+*
+         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL ZTRSM( 'Left', 'Lower', 'Conjugate transpose', 'Non-unit',
+     $               N, NRHS, ONE, A, LDA, B, LDB )
+      END IF
+*
+      RETURN
+*
+*     End of ZPOTRS
+*
+      END
diff --git a/SRC/zppcon.f b/SRC/zppcon.f
new file mode 100644
index 00000000..100cac58
--- /dev/null
+++ b/SRC/zppcon.f
@@ -0,0 +1,183 @@
+      SUBROUTINE ZPPCON( UPLO, N, AP, 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          UPLO
+      INTEGER            INFO, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite packed matrix using
+*  the Cholesky factorization A = U**H*U or A = L*L**H computed by
+*  ZPPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          The 1-norm (or infinity-norm) of the Hermitian 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) 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
+*
+*  =====================================================================
+*
+*     .. 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
+      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, ZLATPS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL ZLATPS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, AP, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL ZLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEU, RWORK, INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL ZLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   AP, WORK, SCALEL, RWORK, INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL ZLATPS( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, AP, WORK, SCALEU, RWORK, INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         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 ZPPCON
+*
+      END
diff --git a/SRC/zppequ.f b/SRC/zppequ.f
new file mode 100644
index 00000000..990a5bd7
--- /dev/null
+++ b/SRC/zppequ.f
@@ -0,0 +1,169 @@
+      SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, 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
+      DOUBLE PRECISION   AMAX, SCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   S( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPEQU computes row and column scalings intended to equilibrate a
+*  Hermitian positive definite matrix A in packed storage and reduce
+*  its condition number (with respect to the two-norm).  S contains the
+*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
+*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
+*  This choice of S puts the condition number of B within a factor N of
+*  the smallest possible condition number over all possible diagonal
+*  scalings.
+*
+*  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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian 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.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, S contains the scale factors for A.
+*
+*  SCOND   (output) DOUBLE PRECISION
+*          If INFO = 0, S contains the ratio of the smallest S(i) to
+*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
+*          large nor too small, it is not worth scaling by S.
+*
+*  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, the i-th diagonal element is nonpositive.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, JJ
+      DOUBLE PRECISION   SMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPPEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SCOND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Initialize SMIN and AMAX.
+*
+      S( 1 ) = DBLE( AP( 1 ) )
+      SMIN = S( 1 )
+      AMAX = S( 1 )
+*
+      IF( UPPER ) THEN
+*
+*        UPLO = 'U':  Upper triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 10 I = 2, N
+            JJ = JJ + I
+            S( I ) = DBLE( AP( JJ ) )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   10    CONTINUE
+*
+      ELSE
+*
+*        UPLO = 'L':  Lower triangle of A is stored.
+*        Find the minimum and maximum diagonal elements.
+*
+         JJ = 1
+         DO 20 I = 2, N
+            JJ = JJ + N - I + 2
+            S( I ) = DBLE( AP( JJ ) )
+            SMIN = MIN( SMIN, S( I ) )
+            AMAX = MAX( AMAX, S( I ) )
+   20    CONTINUE
+      END IF
+*
+      IF( SMIN.LE.ZERO ) THEN
+*
+*        Find the first non-positive diagonal element and return.
+*
+         DO 30 I = 1, N
+            IF( S( I ).LE.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   30    CONTINUE
+      ELSE
+*
+*        Set the scale factors to the reciprocals
+*        of the diagonal elements.
+*
+         DO 40 I = 1, N
+            S( I ) = ONE / SQRT( S( I ) )
+   40    CONTINUE
+*
+*        Compute SCOND = min(S(I)) / max(S(I))
+*
+         SCOND = SQRT( SMIN ) / SQRT( AMAX )
+      END IF
+      RETURN
+*
+*     End of ZPPEQU
+*
+      END
diff --git a/SRC/zpprfs.f b/SRC/zpprfs.f
new file mode 100644
index 00000000..365936c3
--- /dev/null
+++ b/SRC/zpprfs.f
@@ -0,0 +1,335 @@
+      SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
+     $                   BERR, 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          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the Hermitian 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.
+*
+*  AFP     (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,
+*          packed columnwise in a linear array in the same format as A
+*          (see AP).
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZPPTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZHPMV, ZLACN2, ZPPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZHPMV( UPLO, N, -CONE, AP, X( 1, J ), 1, CONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( AP( KK+K-1 ) ) )*
+     $                      XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + ABS( DBLE( AP( KK ) ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
+            CALL ZAXPY( N, CONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZPPRFS
+*
+      END
diff --git a/SRC/zppsv.f b/SRC/zppsv.f
new file mode 100644
index 00000000..6c2809d0
--- /dev/null
+++ b/SRC/zppsv.f
@@ -0,0 +1,133 @@
+      SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  The Cholesky decomposition is used to factor A as
+*     A = U**H* U,  if UPLO = 'U', or
+*     A = L * L**H,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is a lower triangular
+*  matrix.  The factored form of A is then used to solve the system of
+*  equations A * X = B.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, in the same storage
+*          format as A.
+*
+*  B       (input/output) COMPLEX*16 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).
+*
+*  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 of A is not
+*                positive definite, so the factorization could not be
+*                completed, and the solution has not been computed.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZPPTRF, ZPPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+      CALL ZPPTRF( UPLO, N, AP, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of ZPPSV
+*
+      END
diff --git a/SRC/zppsvx.f b/SRC/zppsvx.f
new file mode 100644
index 00000000..c3167479
--- /dev/null
+++ b/SRC/zppsvx.f
@@ -0,0 +1,381 @@
+      SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
+     $                   X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * ), S( * )
+      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
+*  compute the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N Hermitian positive definite matrix stored in
+*  packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+*     factor the matrix A (after equilibration if FACT = 'E') as
+*        A = U'* U ,  if UPLO = 'U', or
+*        A = L * L',  if UPLO = 'L',
+*     where U is an upper triangular matrix, L is a lower triangular
+*     matrix, and ' indicates conjugate transpose.
+*
+*  3. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(S) so that it solves the original system before
+*     equilibration.
+*
+*  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, AFP contains the factored form of A.
+*                  If EQUED = 'Y', the matrix A has been equilibrated
+*                  with scaling factors given by S.  AP and AFP will not
+*                  be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian matrix
+*          A, packed columnwise in a linear array, except if FACT = 'F'
+*          and EQUED = 'Y', then A must contain the equilibrated matrix
+*          diag(S)*A*diag(S).  The j-th column of A is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.  A is not modified if
+*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+*          diag(S)*A*diag(S).
+*
+*  AFP     (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, in the same storage
+*          format as A.  If EQUED .ne. 'N', then AFP is the factored
+*          form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the original
+*          matrix A.
+*
+*          If FACT = 'E', then AFP is an output argument and on exit
+*          returns the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H of the equilibrated
+*          matrix A (see the description of AP for the form of the
+*          equilibrated matrix).
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'Y':  Equilibration was done, i.e., A has been replaced by
+*                  diag(S) * A * diag(S).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  S       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The scale factors for A; not accessed if EQUED = 'N'.  S is
+*          an input argument if FACT = 'F'; otherwise, S is an output
+*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
+*          must be positive.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+*          B is overwritten by diag(S) * B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+*          the original system of equations.  Note that if EQUED = 'Y',
+*          A and B are modified on exit, and the solution to the
+*          equilibrated system is inv(diag(S))*X.
+*
+*  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  Further Details
+*  ===============
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            EQUIL, NOFACT, RCEQU
+      INTEGER            I, INFEQU, J
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHP
+      EXTERNAL           LSAME, DLAMCH, ZLANHP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZLACPY, ZLAQHP, ZPPCON, ZPPEQU,
+     $                   ZPPRFS, ZPPTRF, ZPPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         RCEQU = .FALSE.
+      ELSE
+         RCEQU = LSAME( EQUED, 'Y' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -7
+      ELSE
+         IF( RCEQU ) THEN
+            SMIN = BIGNUM
+            SMAX = ZERO
+            DO 10 J = 1, N
+               SMIN = MIN( SMIN, S( J ) )
+               SMAX = MAX( SMAX, S( J ) )
+   10       CONTINUE
+            IF( SMIN.LE.ZERO ) THEN
+               INFO = -8
+            ELSE IF( N.GT.0 ) THEN
+               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+            ELSE
+               SCOND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -10
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -12
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+            RCEQU = LSAME( EQUED, 'Y' )
+         END IF
+      END IF
+*
+*     Scale the right-hand side.
+*
+      IF( RCEQU ) THEN
+         DO 30 J = 1, NRHS
+            DO 20 I = 1, N
+               B( I, J ) = S( I )*B( I, J )
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+         CALL ZCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL ZPPTRF( UPLO, N, AFP, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANHP( 'I', UPLO, N, AP, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, RWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
+     $             WORK, RWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( RCEQU ) THEN
+         DO 50 J = 1, NRHS
+            DO 40 I = 1, N
+               X( I, J ) = S( I )*X( I, J )
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 J = 1, NRHS
+            FERR( J ) = FERR( J ) / SCOND
+   60    CONTINUE
+      END IF
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZPPSVX
+*
+      END
diff --git a/SRC/zpptrf.f b/SRC/zpptrf.f
new file mode 100644
index 00000000..738eec49
--- /dev/null
+++ b/SRC/zpptrf.f
@@ -0,0 +1,178 @@
+      SUBROUTINE ZPPTRF( 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 ..
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPTRF computes the Cholesky factorization of a complex Hermitian
+*  positive definite matrix A stored in packed format.
+*
+*  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.
+*
+*  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) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the Hermitian 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**H*U or A = L*L**H, 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 Hermitian matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = conjg(aji))
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZHPR, ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, 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( 'ZPPTRF', -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 ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                     J-1, AP, AP( JC ), 1 )
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( AP( JJ ) ) - ZDOTC( 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 = DBLE( 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 ZDSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
+               CALL ZHPR( '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 ZPPTRF
+*
+      END
diff --git a/SRC/zpptri.f b/SRC/zpptri.f
new file mode 100644
index 00000000..98589bea
--- /dev/null
+++ b/SRC/zpptri.f
@@ -0,0 +1,130 @@
+      SUBROUTINE ZPPTRI( 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 ..
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPTRI computes the inverse of a complex Hermitian positive definite
+*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
+*  computed by ZPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangular factor is stored in AP;
+*          = 'L':  Lower triangular factor is stored in AP.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the triangular factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H, packed columnwise as
+*          a linear array.  The j-th column of U or L is stored in the
+*          array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*          On exit, the upper or lower triangle of the (Hermitian)
+*          inverse of A, overwriting the input factor U or L.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the (i,i) element of the factor U or L is
+*                zero, and the inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ, JJN
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZHPR, ZTPMV, ZTPTRI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE
+*     ..
+*     .. 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( 'ZPPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Invert the triangular Cholesky factor U or L.
+*
+      CALL ZTPTRI( UPLO, 'Non-unit', N, AP, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+      IF( UPPER ) THEN
+*
+*        Compute the product inv(U) * inv(U)'.
+*
+         JJ = 0
+         DO 10 J = 1, N
+            JC = JJ + 1
+            JJ = JJ + J
+            IF( J.GT.1 )
+     $         CALL ZHPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
+            AJJ = AP( JJ )
+            CALL ZDSCAL( J, AJJ, AP( JC ), 1 )
+   10    CONTINUE
+*
+      ELSE
+*
+*        Compute the product inv(L)' * inv(L).
+*
+         JJ = 1
+         DO 20 J = 1, N
+            JJN = JJ + N - J + 1
+            AP( JJ ) = DBLE( ZDOTC( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) )
+            IF( J.LT.N )
+     $         CALL ZTPMV( 'Lower', 'Conjugate transpose', 'Non-unit',
+     $                     N-J, AP( JJN ), AP( JJ+1 ), 1 )
+            JJ = JJN
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZPPTRI
+*
+      END
diff --git a/SRC/zpptrs.f b/SRC/zpptrs.f
new file mode 100644
index 00000000..0a9b9266
--- /dev/null
+++ b/SRC/zpptrs.f
@@ -0,0 +1,134 @@
+      SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPPTRS solves a system of linear equations A*X = B with a Hermitian
+*  positive definite matrix A in packed storage using the Cholesky
+*  factorization A = U**H*U or A = L*L**H computed by ZPPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**H*U or A = L*L**H, packed columnwise in a linear
+*          array.  The j-th column of U or L is stored in the array AP
+*          as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPPTRS', -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.
+*
+         DO 10 I = 1, NRHS
+*
+*           Solve U'*X = B, overwriting B with X.
+*
+            CALL ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
+     $                  AP, B( 1, I ), 1 )
+*
+*           Solve U*X = B, overwriting B with X.
+*
+            CALL ZTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+         DO 20 I = 1, NRHS
+*
+*           Solve L*Y = B, overwriting B with X.
+*
+            CALL ZTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
+     $                  B( 1, I ), 1 )
+*
+*           Solve L'*X = Y, overwriting B with X.
+*
+            CALL ZTPSV( 'Lower', 'Conjugate transpose', 'Non-unit', N,
+     $                  AP, B( 1, I ), 1 )
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZPPTRS
+*
+      END
diff --git a/SRC/zptcon.f b/SRC/zptcon.f
new file mode 100644
index 00000000..708fb378
--- /dev/null
+++ b/SRC/zptcon.f
@@ -0,0 +1,150 @@
+      SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), RWORK( * )
+      COMPLEX*16         E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTCON computes the reciprocal of the condition number (in the
+*  1-norm) of a complex Hermitian positive definite tridiagonal matrix
+*  using the factorization A = L*D*L**H or A = U**H*D*U computed by
+*  ZPTTRF.
+*
+*  Norm(inv(A)) is computed by a direct method, and the reciprocal of
+*  the condition number is computed as
+*                   RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization of A, as computed by ZPTTRF.
+*
+*  E       (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the unit bidiagonal factor
+*          U or L from the factorization of A, as computed by ZPTTRF.
+*
+*  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 the
+*          1-norm of inv(A) computed in this routine.
+*
+*  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 method used is described in Nicholas J. Higham, "Efficient
+*  Algorithms for Computing the Condition Number of a Tridiagonal
+*  Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      EXTERNAL           IDAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPTCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that D(1:N) is positive.
+*
+      DO 10 I = 1, N
+         IF( D( I ).LE.ZERO )
+     $      RETURN
+   10 CONTINUE
+*
+*     Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*        m(i,j) =  abs(A(i,j)), i = j,
+*        m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*     and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*     Solve M(L) * x = e.
+*
+      RWORK( 1 ) = ONE
+      DO 20 I = 2, N
+         RWORK( I ) = ONE + RWORK( I-1 )*ABS( E( I-1 ) )
+   20 CONTINUE
+*
+*     Solve D * M(L)' * x = b.
+*
+      RWORK( N ) = RWORK( N ) / D( N )
+      DO 30 I = N - 1, 1, -1
+         RWORK( I ) = RWORK( I ) / D( I ) + RWORK( I+1 )*ABS( E( I ) )
+   30 CONTINUE
+*
+*     Compute AINVNM = max(x(i)), 1<=i<=n.
+*
+      IX = IDAMAX( N, RWORK, 1 )
+      AINVNM = ABS( RWORK( IX ) )
+*
+*     Compute the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of ZPTCON
+*
+      END
diff --git a/SRC/zpteqr.f b/SRC/zpteqr.f
new file mode 100644
index 00000000..eea96599
--- /dev/null
+++ b/SRC/zpteqr.f
@@ -0,0 +1,190 @@
+      SUBROUTINE ZPTEQR( 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
+*  =======
+*
+*  ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric positive definite tridiagonal matrix by first factoring the
+*  matrix using DPTTRF and then calling ZBDSQR to compute the singular
+*  values of the bidiagonal factor.
+*
+*  This routine computes the eigenvalues of the positive definite
+*  tridiagonal matrix to high relative accuracy.  This means that if the
+*  eigenvalues range over many orders of magnitude in size, then the
+*  small eigenvalues and corresponding eigenvectors will be computed
+*  more accurately than, for example, with the standard QR method.
+*
+*  The eigenvectors of a full or band positive definite Hermitian matrix
+*  can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to
+*  reduce this matrix to tridiagonal form.  (The reduction to
+*  tridiagonal form, however, may preclude the possibility of obtaining
+*  high relative accuracy in the small eigenvalues of the original
+*  matrix, if these eigenvalues range over many orders of magnitude.)
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'V':  Compute eigenvectors of original Hermitian
+*                  matrix also.  Array Z contains the unitary matrix
+*                  used to reduce the original matrix to tridiagonal
+*                  form.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*
+*  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 normal exit, D contains the eigenvalues, in descending
+*          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', the unitary matrix used in the
+*          reduction to tridiagonal form.
+*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
+*          original Hermitian matrix;
+*          if COMPZ = 'I', the orthonormal eigenvectors of the
+*          tridiagonal matrix.
+*          If INFO > 0 on exit, Z contains the eigenvectors associated
+*          with only the stored eigenvalues.
+*          If  COMPZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          COMPZ = 'V' or 'I', LDZ >= max(1,N).
+*
+*  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:  if INFO = i, and i is:
+*                <= N  the Cholesky factorization of the matrix could
+*                      not be performed because the i-th principal minor
+*                      was not positive definite.
+*                > N   the SVD algorithm failed to converge;
+*                      if INFO = N+i, i off-diagonal elements of the
+*                      bidiagonal factor did not converge to zero.
+*
+*  ====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPTTRF, XERBLA, ZBDSQR, ZLASET
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         C( 1, 1 ), VT( 1, 1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICOMPZ, NRU
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+     $         N ) ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPTEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.GT.0 )
+     $      Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+      IF( ICOMPZ.EQ.2 )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
+*
+*     Call DPTTRF to factor the matrix.
+*
+      CALL DPTTRF( N, D, E, INFO )
+      IF( INFO.NE.0 )
+     $   RETURN
+      DO 10 I = 1, N
+         D( I ) = SQRT( D( I ) )
+   10 CONTINUE
+      DO 20 I = 1, N - 1
+         E( I ) = E( I )*D( I )
+   20 CONTINUE
+*
+*     Call ZBDSQR to compute the singular values/vectors of the
+*     bidiagonal factor.
+*
+      IF( ICOMPZ.GT.0 ) THEN
+         NRU = N
+      ELSE
+         NRU = 0
+      END IF
+      CALL ZBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
+     $             WORK, INFO )
+*
+*     Square the singular values.
+*
+      IF( INFO.EQ.0 ) THEN
+         DO 30 I = 1, N
+            D( I ) = D( I )*D( I )
+   30    CONTINUE
+      ELSE
+         INFO = N + INFO
+      END IF
+*
+      RETURN
+*
+*     End of ZPTEQR
+*
+      END
diff --git a/SRC/zptrfs.f b/SRC/zptrfs.f
new file mode 100644
index 00000000..26398365
--- /dev/null
+++ b/SRC/zptrfs.f
@@ -0,0 +1,366 @@
+      SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+     $                   FERR, BERR, WORK, 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, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), D( * ), DF( * ), FERR( * ),
+     $                   RWORK( * )
+      COMPLEX*16         B( LDB, * ), E( * ), EF( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is Hermitian positive definite
+*  and tridiagonal, and provides error bounds and backward error
+*  estimates for the solution.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the superdiagonal or the subdiagonal of the
+*          tridiagonal matrix A is stored and the form of the
+*          factorization:
+*          = 'U':  E is the superdiagonal of A, and A = U**H*D*U;
+*          = 'L':  E is the subdiagonal of A, and A = L*D*L**H.
+*          (The two forms are equivalent if A is real.)
+*
+*  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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n real diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the tridiagonal matrix A
+*          (see UPLO).
+*
+*  DF      (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from
+*          the factorization computed by ZPTTRF.
+*
+*  EF      (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) off-diagonal elements of the unit bidiagonal
+*          factor U or L from the factorization computed by ZPTTRF
+*          (see UPLO).
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZPTTRS.
+*          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 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).
+*
+*  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) COMPLEX*16 array, dimension (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
+*
+*  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            UPPER
+      INTEGER            COUNT, I, IX, J, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+      COMPLEX*16         BI, CX, DX, EX, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZPTTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, 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
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPTRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = 4
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 100 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X.  Also compute
+*        abs(A)*abs(x) + abs(b) for use in the backward error bound.
+*
+         IF( UPPER ) THEN
+            IF( N.EQ.1 ) THEN
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               WORK( 1 ) = BI - DX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX )
+            ELSE
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               EX = E( 1 )*X( 2, J )
+               WORK( 1 ) = BI - DX - EX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX ) +
+     $                      CABS1( E( 1 ) )*CABS1( X( 2, J ) )
+               DO 30 I = 2, N - 1
+                  BI = B( I, J )
+                  CX = DCONJG( E( I-1 ) )*X( I-1, J )
+                  DX = D( I )*X( I, J )
+                  EX = E( I )*X( I+1, J )
+                  WORK( I ) = BI - CX - DX - EX
+                  RWORK( I ) = CABS1( BI ) +
+     $                         CABS1( E( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( DX ) + CABS1( E( I ) )*
+     $                         CABS1( X( I+1, J ) )
+   30          CONTINUE
+               BI = B( N, J )
+               CX = DCONJG( E( N-1 ) )*X( N-1, J )
+               DX = D( N )*X( N, J )
+               WORK( N ) = BI - CX - DX
+               RWORK( N ) = CABS1( BI ) + CABS1( E( N-1 ) )*
+     $                      CABS1( X( N-1, J ) ) + CABS1( DX )
+            END IF
+         ELSE
+            IF( N.EQ.1 ) THEN
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               WORK( 1 ) = BI - DX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX )
+            ELSE
+               BI = B( 1, J )
+               DX = D( 1 )*X( 1, J )
+               EX = DCONJG( E( 1 ) )*X( 2, J )
+               WORK( 1 ) = BI - DX - EX
+               RWORK( 1 ) = CABS1( BI ) + CABS1( DX ) +
+     $                      CABS1( E( 1 ) )*CABS1( X( 2, J ) )
+               DO 40 I = 2, N - 1
+                  BI = B( I, J )
+                  CX = E( I-1 )*X( I-1, J )
+                  DX = D( I )*X( I, J )
+                  EX = DCONJG( E( I ) )*X( I+1, J )
+                  WORK( I ) = BI - CX - DX - EX
+                  RWORK( I ) = CABS1( BI ) +
+     $                         CABS1( E( I-1 ) )*CABS1( X( I-1, J ) ) +
+     $                         CABS1( DX ) + CABS1( E( I ) )*
+     $                         CABS1( X( I+1, J ) )
+   40          CONTINUE
+               BI = B( N, J )
+               CX = E( N-1 )*X( N-1, J )
+               DX = D( N )*X( N, J )
+               WORK( N ) = BI - CX - DX
+               RWORK( N ) = CABS1( BI ) + CABS1( E( N-1 ) )*
+     $                      CABS1( X( N-1, J ) ) + CABS1( DX )
+            END IF
+         END IF
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         S = ZERO
+         DO 50 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+   50    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL ZPTTRS( UPLO, N, 1, DF, EF, WORK, N, INFO )
+            CALL ZAXPY( N, DCMPLX( ONE ), WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+         DO 60 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   60    CONTINUE
+         IX = IDAMAX( N, RWORK, 1 )
+         FERR( J ) = RWORK( IX )
+*
+*        Estimate the norm of inv(A).
+*
+*        Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+*           m(i,j) =  abs(A(i,j)), i = j,
+*           m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+*        and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
+*
+*        Solve M(L) * x = e.
+*
+         RWORK( 1 ) = ONE
+         DO 70 I = 2, N
+            RWORK( I ) = ONE + RWORK( I-1 )*ABS( EF( I-1 ) )
+   70    CONTINUE
+*
+*        Solve D * M(L)' * x = b.
+*
+         RWORK( N ) = RWORK( N ) / DF( N )
+         DO 80 I = N - 1, 1, -1
+            RWORK( I ) = RWORK( I ) / DF( I ) +
+     $                   RWORK( I+1 )*ABS( EF( I ) )
+   80    CONTINUE
+*
+*        Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
+*
+         IX = IDAMAX( N, RWORK, 1 )
+         FERR( J ) = FERR( J )*ABS( RWORK( IX ) )
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 90 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+   90    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of ZPTRFS
+*
+      END
diff --git a/SRC/zptsv.f b/SRC/zptsv.f
new file mode 100644
index 00000000..da0f7776
--- /dev/null
+++ b/SRC/zptsv.f
@@ -0,0 +1,100 @@
+      SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * )
+      COMPLEX*16         B( LDB, * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTSV computes the solution to a complex system of linear equations
+*  A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal
+*  matrix, and X and B are N-by-NRHS matrices.
+*
+*  A is factored as A = L*D*L**H, and the factored form of A is then
+*  used to solve the system of equations.
+*
+*  Arguments
+*  =========
+*
+*  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.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the factorization A = L*D*L**H.
+*
+*  E       (input/output) COMPLEX*16 array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L**H factorization of
+*          A.  E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U**H*D*U factorization of A.
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          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).
+*
+*  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 solution has not been
+*                computed.  The factorization has not been completed
+*                unless i = N.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZPTTRF, ZPTTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPTSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      CALL ZPTTRF( N, D, E, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZPTTRS( 'Lower', N, NRHS, D, E, B, LDB, INFO )
+      END IF
+      RETURN
+*
+*     End of ZPTSV
+*
+      END
diff --git a/SRC/zptsvx.f b/SRC/zptsvx.f
new file mode 100644
index 00000000..52b95f69
--- /dev/null
+++ b/SRC/zptsvx.f
@@ -0,0 +1,236 @@
+      SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+     $                   RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), D( * ), DF( * ), FERR( * ),
+     $                   RWORK( * )
+      COMPLEX*16         B( LDB, * ), E( * ), EF( * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTSVX uses the factorization A = L*D*L**H to compute the solution
+*  to a complex system of linear equations A*X = B, where A is an
+*  N-by-N Hermitian positive definite tridiagonal matrix and X and B
+*  are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L
+*     is a unit lower bidiagonal matrix and D is diagonal.  The
+*     factorization can also be regarded as having the form
+*     A = U**H*D*U.
+*
+*  2. If the leading i-by-i principal minor is not positive definite,
+*     then the routine returns with INFO = i. Otherwise, the factored
+*     form of A is used to estimate the condition number of the matrix
+*     A.  If the reciprocal of the condition number is less than machine
+*     precision, INFO = N+1 is returned as a warning, but the routine
+*     still goes on to solve for X and compute error bounds as
+*     described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of the matrix
+*          A is supplied on entry.
+*          = 'F':  On entry, DF and EF contain the factored form of A.
+*                  D, E, DF, and EF will not be modified.
+*          = 'N':  The matrix A will be copied to DF and EF and
+*                  factored.
+*
+*  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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix A.
+*
+*  E       (input) COMPLEX*16 array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+*  DF      (input or output) DOUBLE PRECISION array, dimension (N)
+*          If FACT = 'F', then DF is an input argument and on entry
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**H factorization of A.
+*          If FACT = 'N', then DF is an output argument and on exit
+*          contains the n diagonal elements of the diagonal matrix D
+*          from the L*D*L**H factorization of A.
+*
+*  EF      (input or output) COMPLEX*16 array, dimension (N-1)
+*          If FACT = 'F', then EF is an input argument and on entry
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**H factorization of A.
+*          If FACT = 'N', then EF is an output argument and on exit
+*          contains the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the L*D*L**H factorization of A.
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal condition number of the matrix A.  If RCOND
+*          is less than the machine precision (in particular, if
+*          RCOND = 0), the matrix is singular to working precision.
+*          This condition is indicated by a return code of INFO > 0.
+*
+*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
+*          The forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).
+*
+*  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) COMPLEX*16 array, dimension (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
+*          > 0:  if INFO = i, and i is
+*                <= N:  the leading minor of order i of A is
+*                       not positive definite, so the factorization
+*                       could not be completed, and the solution has not
+*                       been computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHT
+      EXTERNAL           LSAME, DLAMCH, ZLANHT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, XERBLA, ZCOPY, ZLACPY, ZPTCON, ZPTRFS,
+     $                   ZPTTRF, ZPTTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPTSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+         CALL DCOPY( N, D, 1, DF, 1 )
+         IF( N.GT.1 )
+     $      CALL ZCOPY( N-1, E, 1, EF, 1 )
+         CALL ZPTTRF( N, DF, EF, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANHT( '1', N, D, E )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZPTCON( N, DF, EF, ANORM, RCOND, RWORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZPTTRS( 'Lower', N, NRHS, DF, EF, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL ZPTRFS( 'Lower', N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZPTSVX
+*
+      END
diff --git a/SRC/zpttrf.f b/SRC/zpttrf.f
new file mode 100644
index 00000000..6deda45f
--- /dev/null
+++ b/SRC/zpttrf.f
@@ -0,0 +1,168 @@
+      SUBROUTINE ZPTTRF( 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( * )
+      COMPLEX*16         E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTTRF computes the L*D*L' factorization of a complex Hermitian
+*  positive definite tridiagonal matrix A.  The factorization may also
+*  be regarded as having the form A = U'*D*U.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix
+*          A.  On exit, the n diagonal elements of the diagonal matrix
+*          D from the L*D*L' factorization of A.
+*
+*  E       (input/output) COMPLEX*16 array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix A.  On exit, the (n-1) subdiagonal elements of the
+*          unit bidiagonal factor L from the L*D*L' factorization of A.
+*          E can also be regarded as the superdiagonal of the unit
+*          bidiagonal factor U from the U'*D*U factorization of A.
+*
+*  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; if k < N, the factorization could not
+*               be completed, while if k = N, the factorization was
+*               completed, but D(N) <= 0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I4
+      DOUBLE PRECISION   EII, EIR, F, G
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DIMAG, MOD
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'ZPTTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+      I4 = MOD( N-1, 4 )
+      DO 10 I = 1, I4
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 30
+         END IF
+         EIR = DBLE( E( I ) )
+         EII = DIMAG( E( I ) )
+         F = EIR / D( I )
+         G = EII / D( I )
+         E( I ) = DCMPLX( F, G )
+         D( I+1 ) = D( I+1 ) - F*EIR - G*EII
+   10 CONTINUE
+*
+      DO 20 I = I4 + 1, N - 4, 4
+*
+*        Drop out of the loop if d(i) <= 0: the matrix is not positive
+*        definite.
+*
+         IF( D( I ).LE.ZERO ) THEN
+            INFO = I
+            GO TO 30
+         END IF
+*
+*        Solve for e(i) and d(i+1).
+*
+         EIR = DBLE( E( I ) )
+         EII = DIMAG( E( I ) )
+         F = EIR / D( I )
+         G = EII / D( I )
+         E( I ) = DCMPLX( F, G )
+         D( I+1 ) = D( I+1 ) - F*EIR - G*EII
+*
+         IF( D( I+1 ).LE.ZERO ) THEN
+            INFO = I + 1
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+1) and d(i+2).
+*
+         EIR = DBLE( E( I+1 ) )
+         EII = DIMAG( E( I+1 ) )
+         F = EIR / D( I+1 )
+         G = EII / D( I+1 )
+         E( I+1 ) = DCMPLX( F, G )
+         D( I+2 ) = D( I+2 ) - F*EIR - G*EII
+*
+         IF( D( I+2 ).LE.ZERO ) THEN
+            INFO = I + 2
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+2) and d(i+3).
+*
+         EIR = DBLE( E( I+2 ) )
+         EII = DIMAG( E( I+2 ) )
+         F = EIR / D( I+2 )
+         G = EII / D( I+2 )
+         E( I+2 ) = DCMPLX( F, G )
+         D( I+3 ) = D( I+3 ) - F*EIR - G*EII
+*
+         IF( D( I+3 ).LE.ZERO ) THEN
+            INFO = I + 3
+            GO TO 30
+         END IF
+*
+*        Solve for e(i+3) and d(i+4).
+*
+         EIR = DBLE( E( I+3 ) )
+         EII = DIMAG( E( I+3 ) )
+         F = EIR / D( I+3 )
+         G = EII / D( I+3 )
+         E( I+3 ) = DCMPLX( F, G )
+         D( I+4 ) = D( I+4 ) - F*EIR - G*EII
+   20 CONTINUE
+*
+*     Check d(n) for positive definiteness.
+*
+      IF( D( N ).LE.ZERO )
+     $   INFO = N
+*
+   30 CONTINUE
+      RETURN
+*
+*     End of ZPTTRF
+*
+      END
diff --git a/SRC/zpttrs.f b/SRC/zpttrs.f
new file mode 100644
index 00000000..e372d00b
--- /dev/null
+++ b/SRC/zpttrs.f
@@ -0,0 +1,135 @@
+      SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * )
+      COMPLEX*16         B( LDB, * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTTRS solves a tridiagonal system of the form
+*     A * X = B
+*  using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.
+*  D is a diagonal matrix specified in the vector D, U (or L) is a unit
+*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
+*  the vector E, and X and B are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies the form of the factorization and whether the
+*          vector E is the superdiagonal of the upper bidiagonal factor
+*          U or the subdiagonal of the lower bidiagonal factor L.
+*          = 'U':  A = U'*D*U, E is the superdiagonal of U
+*          = 'L':  A = L*D*L', E is the subdiagonal of L
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization A = U'*D*U or A = L*D*L'.
+*
+*  E       (input) COMPLEX*16 array, dimension (N-1)
+*          If UPLO = 'U', the (n-1) superdiagonal elements of the unit
+*          bidiagonal factor U from the factorization A = U'*D*U.
+*          If UPLO = 'L', the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the factorization A = L*D*L'.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            IUPLO, J, JB, NB
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZPTTS2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      UPPER = ( UPLO.EQ.'U' .OR. UPLO.EQ.'u' )
+      IF( .NOT.UPPER .AND. .NOT.( UPLO.EQ.'L' .OR. UPLO.EQ.'l' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPTTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+*     Determine the number of right-hand sides to solve at a time.
+*
+      IF( NRHS.EQ.1 ) THEN
+         NB = 1
+      ELSE
+         NB = MAX( 1, ILAENV( 1, 'ZPTTRS', UPLO, N, NRHS, -1, -1 ) )
+      END IF
+*
+*     Decode UPLO
+*
+      IF( UPPER ) THEN
+         IUPLO = 1
+      ELSE
+         IUPLO = 0
+      END IF
+*
+      IF( NB.GE.NRHS ) THEN
+         CALL ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
+      ELSE
+         DO 10 J = 1, NRHS, NB
+            JB = MIN( NRHS-J+1, NB )
+            CALL ZPTTS2( IUPLO, N, JB, D, E, B( 1, J ), LDB )
+   10    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZPTTRS
+*
+      END
diff --git a/SRC/zptts2.f b/SRC/zptts2.f
new file mode 100644
index 00000000..e2a90fc3
--- /dev/null
+++ b/SRC/zptts2.f
@@ -0,0 +1,176 @@
+      SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IUPLO, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * )
+      COMPLEX*16         B( LDB, * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPTTS2 solves a tridiagonal system of the form
+*     A * X = B
+*  using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.
+*  D is a diagonal matrix specified in the vector D, U (or L) is a unit
+*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
+*  the vector E, and X and B are N by NRHS matrices.
+*
+*  Arguments
+*  =========
+*
+*  IUPLO   (input) INTEGER
+*          Specifies the form of the factorization and whether the
+*          vector E is the superdiagonal of the upper bidiagonal factor
+*          U or the subdiagonal of the lower bidiagonal factor L.
+*          = 1:  A = U'*D*U, E is the superdiagonal of U
+*          = 0:  A = L*D*L', E is the subdiagonal of L
+*
+*  N       (input) INTEGER
+*          The order of the tridiagonal 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.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the diagonal matrix D from the
+*          factorization A = U'*D*U or A = L*D*L'.
+*
+*  E       (input) COMPLEX*16 array, dimension (N-1)
+*          If IUPLO = 1, the (n-1) superdiagonal elements of the unit
+*          bidiagonal factor U from the factorization A = U'*D*U.
+*          If IUPLO = 0, the (n-1) subdiagonal elements of the unit
+*          bidiagonal factor L from the factorization A = L*D*L'.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side vectors B for the system of
+*          linear equations.
+*          On exit, the solution vectors, X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZDSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 ) THEN
+         IF( N.EQ.1 )
+     $      CALL ZDSCAL( NRHS, 1.D0 / D( 1 ), B, LDB )
+         RETURN
+      END IF
+*
+      IF( IUPLO.EQ.1 ) THEN
+*
+*        Solve A * X = B using the factorization A = U'*D*U,
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.2 ) THEN
+            J = 1
+   10       CONTINUE
+*
+*           Solve U' * x = b.
+*
+            DO 20 I = 2, N
+               B( I, J ) = B( I, J ) - B( I-1, J )*DCONJG( E( I-1 ) )
+   20       CONTINUE
+*
+*           Solve D * U * x = b.
+*
+            DO 30 I = 1, N
+               B( I, J ) = B( I, J ) / D( I )
+   30       CONTINUE
+            DO 40 I = N - 1, 1, -1
+               B( I, J ) = B( I, J ) - B( I+1, J )*E( I )
+   40       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 10
+            END IF
+         ELSE
+            DO 70 J = 1, NRHS
+*
+*              Solve U' * x = b.
+*
+               DO 50 I = 2, N
+                  B( I, J ) = B( I, J ) - B( I-1, J )*DCONJG( E( I-1 ) )
+   50          CONTINUE
+*
+*              Solve D * U * x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               DO 60 I = N - 1, 1, -1
+                  B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
+   60          CONTINUE
+   70       CONTINUE
+         END IF
+      ELSE
+*
+*        Solve A * X = B using the factorization A = L*D*L',
+*        overwriting each right hand side vector with its solution.
+*
+         IF( NRHS.LE.2 ) THEN
+            J = 1
+   80       CONTINUE
+*
+*           Solve L * x = b.
+*
+            DO 90 I = 2, N
+               B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+   90       CONTINUE
+*
+*           Solve D * L' * x = b.
+*
+            DO 100 I = 1, N
+               B( I, J ) = B( I, J ) / D( I )
+  100       CONTINUE
+            DO 110 I = N - 1, 1, -1
+               B( I, J ) = B( I, J ) - B( I+1, J )*DCONJG( E( I ) )
+  110       CONTINUE
+            IF( J.LT.NRHS ) THEN
+               J = J + 1
+               GO TO 80
+            END IF
+         ELSE
+            DO 140 J = 1, NRHS
+*
+*              Solve L * x = b.
+*
+               DO 120 I = 2, N
+                  B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+  120          CONTINUE
+*
+*              Solve D * L' * x = b.
+*
+               B( N, J ) = B( N, J ) / D( N )
+               DO 130 I = N - 1, 1, -1
+                  B( I, J ) = B( I, J ) / D( I ) -
+     $                        B( I+1, J )*DCONJG( E( I ) )
+  130          CONTINUE
+  140       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZPTTS2
+*
+      END
diff --git a/SRC/zrot.f b/SRC/zrot.f
new file mode 100644
index 00000000..9c548e23
--- /dev/null
+++ b/SRC/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/zspcon.f b/SRC/zspcon.f
new file mode 100644
index 00000000..edd2ab43
--- /dev/null
+++ b/SRC/zspcon.f
@@ -0,0 +1,159 @@
+      SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, 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          UPLO
+      INTEGER            INFO, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex symmetric packed matrix A using the
+*  factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZSPTRF.
+*
+*  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) COMPLEX*16 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            UPPER
+      INTEGER            I, IP, KASE
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACN2, ZSPTRS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         IP = N*( N+1 ) / 2
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP - I
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         IP = 1
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+     $         RETURN
+            IP = IP + N - I + 1
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL ZSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of ZSPCON
+*
+      END
diff --git a/SRC/zspmv.f b/SRC/zspmv.f
new file mode 100644
index 00000000..c8b9fba6
--- /dev/null
+++ b/SRC/zspmv.f
@@ -0,0 +1,264 @@
+      SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INCX, INCY, N
+      COMPLEX*16         ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPMV  performs the matrix-vector operation
+*
+*     y := alpha*A*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are n element vectors and
+*  A is an n by n symmetric matrix, supplied in packed form.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the matrix A is supplied in the packed
+*           array AP as follows:
+*
+*              UPLO = 'U' or 'u'   The upper triangular part of A is
+*                                  supplied in AP.
+*
+*              UPLO = 'L' or 'l'   The lower triangular part of A is
+*                                  supplied in AP.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX*16
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  AP       (input) COMPLEX*16 array, dimension at least
+*           ( ( N*( N + 1 ) )/2 ).
+*           Before entry, with UPLO = 'U' or 'u', the array AP must
+*           contain the upper triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+*           and a( 2, 2 ) respectively, and so on.
+*           Before entry, with UPLO = 'L' or 'l', the array AP must
+*           contain the lower triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+*           and a( 3, 1 ) respectively, and so on.
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA     (input) COMPLEX*16
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y        (input/output) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y. On exit, Y is overwritten by the updated
+*           vector y.
+*
+*  INCY     (input) INTEGER
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
+      COMPLEX*16         TEMP1, TEMP2
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 6
+      ELSE IF( INCY.EQ.0 ) THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     Set up the start points in  X  and  Y.
+*
+      IF( INCX.GT.0 ) THEN
+         KX = 1
+      ELSE
+         KX = 1 - ( N-1 )*INCX
+      END IF
+      IF( INCY.GT.0 ) THEN
+         KY = 1
+      ELSE
+         KY = 1 - ( N-1 )*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of the array AP
+*     are accessed sequentially with one pass through AP.
+*
+*     First form  y := beta*y.
+*
+      IF( BETA.NE.ONE ) THEN
+         IF( INCY.EQ.1 ) THEN
+            IF( BETA.EQ.ZERO ) THEN
+               DO 10 I = 1, N
+                  Y( I ) = ZERO
+   10          CONTINUE
+            ELSE
+               DO 20 I = 1, N
+                  Y( I ) = BETA*Y( I )
+   20          CONTINUE
+            END IF
+         ELSE
+            IY = KY
+            IF( BETA.EQ.ZERO ) THEN
+               DO 30 I = 1, N
+                  Y( IY ) = ZERO
+                  IY = IY + INCY
+   30          CONTINUE
+            ELSE
+               DO 40 I = 1, N
+                  Y( IY ) = BETA*Y( IY )
+                  IY = IY + INCY
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      IF( ALPHA.EQ.ZERO )
+     $   RETURN
+      KK = 1
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  y  when AP contains the upper triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 60 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               K = KK
+               DO 50 I = 1, J - 1
+                  Y( I ) = Y( I ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( I )
+                  K = K + 1
+   50          CONTINUE
+               Y( J ) = Y( J ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
+               KK = KK + J
+   60       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 80 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               IX = KX
+               IY = KY
+               DO 70 K = KK, KK + J - 2
+                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( IX )
+                  IX = IX + INCX
+                  IY = IY + INCY
+   70          CONTINUE
+               Y( JY ) = Y( JY ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+               KK = KK + J
+   80       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  y  when AP contains the lower triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 100 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               Y( J ) = Y( J ) + TEMP1*AP( KK )
+               K = KK + 1
+               DO 90 I = J + 1, N
+                  Y( I ) = Y( I ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( I )
+                  K = K + 1
+   90          CONTINUE
+               Y( J ) = Y( J ) + ALPHA*TEMP2
+               KK = KK + ( N-J+1 )
+  100       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 120 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               Y( JY ) = Y( JY ) + TEMP1*AP( KK )
+               IX = JX
+               IY = JY
+               DO 110 K = KK + 1, KK + N - J
+                  IX = IX + INCX
+                  IY = IY + INCY
+                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
+                  TEMP2 = TEMP2 + AP( K )*X( IX )
+  110          CONTINUE
+               Y( JY ) = Y( JY ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+               KK = KK + ( N-J+1 )
+  120       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZSPMV
+*
+      END
diff --git a/SRC/zspr.f b/SRC/zspr.f
new file mode 100644
index 00000000..96c7d006
--- /dev/null
+++ b/SRC/zspr.f
@@ -0,0 +1,213 @@
+      SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INCX, N
+      COMPLEX*16         ALPHA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPR    performs the symmetric rank 1 operation
+*
+*     A := alpha*x*conjg( x' ) + A,
+*
+*  where alpha is a complex scalar, x is an n element vector and A is an
+*  n by n symmetric matrix, supplied in packed form.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the matrix A is supplied in the packed
+*           array AP as follows:
+*
+*              UPLO = 'U' or 'u'   The upper triangular part of A is
+*                                  supplied in AP.
+*
+*              UPLO = 'L' or 'l'   The lower triangular part of A is
+*                                  supplied in AP.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX*16
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  AP       (input/output) COMPLEX*16 array, dimension at least
+*           ( ( N*( N + 1 ) )/2 ).
+*           Before entry, with  UPLO = 'U' or 'u', the array AP must
+*           contain the upper triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+*           and a( 2, 2 ) respectively, and so on. On exit, the array
+*           AP is overwritten by the upper triangular part of the
+*           updated matrix.
+*           Before entry, with UPLO = 'L' or 'l', the array AP must
+*           contain the lower triangular part of the symmetric matrix
+*           packed sequentially, column by column, so that AP( 1 )
+*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+*           and a( 3, 1 ) respectively, and so on. On exit, the array
+*           AP is overwritten by the lower triangular part of the
+*           updated matrix.
+*           Note that the imaginary parts of the diagonal elements need
+*           not be set, they are assumed to be zero, and on exit they
+*           are set to zero.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, J, JX, K, KK, KX
+      COMPLEX*16         TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPR  ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Set the start point in X if the increment is not unity.
+*
+      IF( INCX.LE.0 ) THEN
+         KX = 1 - ( N-1 )*INCX
+      ELSE IF( INCX.NE.1 ) THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of the array AP
+*     are accessed sequentially with one pass through AP.
+*
+      KK = 1
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  A  when upper triangle is stored in AP.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 20 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  K = KK
+                  DO 10 I = 1, J - 1
+                     AP( K ) = AP( K ) + X( I )*TEMP
+                     K = K + 1
+   10             CONTINUE
+                  AP( KK+J-1 ) = AP( KK+J-1 ) + X( J )*TEMP
+               ELSE
+                  AP( KK+J-1 ) = AP( KK+J-1 )
+               END IF
+               KK = KK + J
+   20       CONTINUE
+         ELSE
+            JX = KX
+            DO 40 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  IX = KX
+                  DO 30 K = KK, KK + J - 2
+                     AP( K ) = AP( K ) + X( IX )*TEMP
+                     IX = IX + INCX
+   30             CONTINUE
+                  AP( KK+J-1 ) = AP( KK+J-1 ) + X( JX )*TEMP
+               ELSE
+                  AP( KK+J-1 ) = AP( KK+J-1 )
+               END IF
+               JX = JX + INCX
+               KK = KK + J
+   40       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  A  when lower triangle is stored in AP.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 60 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  AP( KK ) = AP( KK ) + TEMP*X( J )
+                  K = KK + 1
+                  DO 50 I = J + 1, N
+                     AP( K ) = AP( K ) + X( I )*TEMP
+                     K = K + 1
+   50             CONTINUE
+               ELSE
+                  AP( KK ) = AP( KK )
+               END IF
+               KK = KK + N - J + 1
+   60       CONTINUE
+         ELSE
+            JX = KX
+            DO 80 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  AP( KK ) = AP( KK ) + TEMP*X( JX )
+                  IX = JX
+                  DO 70 K = KK + 1, KK + N - J
+                     IX = IX + INCX
+                     AP( K ) = AP( K ) + X( IX )*TEMP
+   70             CONTINUE
+               ELSE
+                  AP( KK ) = AP( KK )
+               END IF
+               JX = JX + INCX
+               KK = KK + N - J + 1
+   80       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZSPR
+*
+      END
diff --git a/SRC/zsprfs.f b/SRC/zsprfs.f
new file mode 100644
index 00000000..93661a04
--- /dev/null
+++ b/SRC/zsprfs.f
@@ -0,0 +1,340 @@
+      SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
+     $                   FERR, BERR, 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          UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite
+*  and packed, and provides error bounds and backward error estimates
+*  for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  AFP     (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The factored form of the matrix A.  AFP contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by ZSPTRF, stored as a packed
+*          triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZSPTRF.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZSPTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZLACN2, ZSPMV, ZSPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         KK = 1
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               IK = KK
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + CABS1( AP( KK+K-1 ) )*XK + S
+               KK = KK + K
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + CABS1( AP( KK ) )*XK
+               IK = KK + 1
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
+                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
+                  IK = IK + 1
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+               KK = KK + ( N-K+1 )
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZSPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZSPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZSPTRS( UPLO, N, 1, AFP, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZSPRFS
+*
+      END
diff --git a/SRC/zspsv.f b/SRC/zspsv.f
new file mode 100644
index 00000000..46f73786
--- /dev/null
+++ b/SRC/zspsv.f
@@ -0,0 +1,148 @@
+      SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPSV computes the solution to a complex system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric matrix stored in packed format and X
+*  and B are N-by-NRHS matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**T,  if UPLO = 'U', or
+*     A = L * D * L**T,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, D is symmetric and block diagonal with 1-by-1
+*  and 2-by-2 diagonal blocks.  The factored form of A is then used to
+*  solve the system of equations A * X = B.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by ZSPTRF.  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) COMPLEX*16 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).
+*
+*  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.
+*
+*  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 ]
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZSPTRF, ZSPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPSV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL ZSPTRF( UPLO, N, AP, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+      END IF
+      RETURN
+*
+*     End of ZSPSV
+*
+      END
diff --git a/SRC/zspsvx.f b/SRC/zspsvx.f
new file mode 100644
index 00000000..70704e06
--- /dev/null
+++ b/SRC/zspsvx.f
@@ -0,0 +1,277 @@
+      SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
+     $                   LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          FACT, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
+*  A = L*D*L**T to compute the solution to a complex system of linear
+*  equations A * X = B, where A is an N-by-N symmetric matrix stored
+*  in packed format and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AFP and IPIV contain the factored form
+*                  of A.  AP, AFP and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AFP and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*  AFP     (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          If FACT = 'F', then AFP is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*          If FACT = 'N', then AFP is an output argument and on exit
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as
+*          a packed triangular matrix in the same storage format as A.
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains details of the interchanges and the block structure
+*          of D, as determined by ZSPTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by ZSPTRF.
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  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.  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) 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
+*          > 0:  if INFO = i, and i is
+*                <= N:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  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   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOFACT
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANSP
+      EXTERNAL           LSAME, DLAMCH, ZLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZLACPY, ZSPCON, ZSPRFS, ZSPTRF,
+     $                   ZSPTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPSVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL ZCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+         CALL ZSPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANSP( 'I', UPLO, N, AP, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+     $             BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      RETURN
+*
+*     End of ZSPSVX
+*
+      END
diff --git a/SRC/zsptrf.f b/SRC/zsptrf.f
new file mode 100644
index 00000000..30f9295c
--- /dev/null
+++ b/SRC/zsptrf.f
@@ -0,0 +1,555 @@
+      SUBROUTINE ZSPTRF( 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( * )
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPTRF computes the factorization of a complex 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) COMPLEX*16 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 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.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, ROWMAX
+      COMPLEX*16         D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      EXTERNAL           LSAME, IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZSCAL, ZSPR, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. 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( 'ZSPTRF', -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 = CABS1( 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 = IZAMAX( K-1, AP( KC ), 1 )
+            COLMAX = CABS1( 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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( AP( KX ) )
+                     JMAX = J
+                  END IF
+                  KX = KX + J
+   20          CONTINUE
+               KPC = ( IMAX-1 )*IMAX / 2 + 1
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IZAMAX( IMAX-1, AP( KPC ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 ZSWAP( 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 = CONE / AP( KC+K-1 )
+               CALL ZSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+*              Store U(k) in column k
+*
+               CALL ZSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 = CABS1( 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 + IZAMAX( N-K, AP( KC+1 ), 1 )
+            COLMAX = CABS1( 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( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = CABS1( 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 + IZAMAX( N-IMAX, AP( KPC+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 ZSWAP( 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 = CONE / AP( KC )
+                  CALL ZSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+     $                       AP( KC+N-K+1 ) )
+*
+*                 Store L(k) in column K
+*
+                  CALL ZSCAL( 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) )'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
+                  D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
+                  D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
+                  T = CONE / ( D11*D22-CONE )
+                  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 ZSPTRF
+*
+      END
diff --git a/SRC/zsptri.f b/SRC/zsptri.f
new file mode 100644
index 00000000..fe0cc2a7
--- /dev/null
+++ b/SRC/zsptri.f
@@ -0,0 +1,337 @@
+      SUBROUTINE ZSPTRI( UPLO, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPTRI computes the inverse of a complex symmetric indefinite matrix
+*  A in packed storage using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by ZSPTRF.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by ZSPTRF,
+*          stored as a packed triangular matrix.
+*
+*          On exit, if INFO = 0, the (symmetric) inverse of the original
+*          matrix, stored as a packed triangular matrix. The j-th column
+*          of inv(A) is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+*          if UPLO = 'L',
+*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZSPTRF.
+*
+*  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
+*          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*               inverse could 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            UPPER
+      INTEGER            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+      COMPLEX*16         AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTU
+      EXTERNAL           LSAME, ZDOTU
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZSPMV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         KP = N*( N+1 ) / 2
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP - INFO
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         KP = 1
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+     $         RETURN
+            KP = KP + N - INFO + 1
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         KCNEXT = KC + K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC+K-1 ) = ONE / AP( KC+K-1 )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL ZSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        ZDOTU( K-1, WORK, 1, AP( KC ), 1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = AP( KCNEXT+K-1 )
+            AK = AP( KC+K-1 ) / T
+            AKP1 = AP( KCNEXT+K ) / T
+            AKKP1 = AP( KCNEXT+K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KC+K-1 ) = AKP1 / D
+            AP( KCNEXT+K ) = AK / D
+            AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL ZCOPY( K-1, AP( KC ), 1, WORK, 1 )
+               CALL ZSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+     $                     1 )
+               AP( KC+K-1 ) = AP( KC+K-1 ) -
+     $                        ZDOTU( K-1, WORK, 1, AP( KC ), 1 )
+               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+     $                            ZDOTU( K-1, AP( KC ), 1, AP( KCNEXT ),
+     $                            1 )
+               CALL ZCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+               CALL ZSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
+     $                     AP( KCNEXT ), 1 )
+               AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+     $                          ZDOTU( K-1, WORK, 1, AP( KCNEXT ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT + K + 1
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            KPC = ( KP-1 )*KP / 2 + 1
+            CALL ZSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+            KX = KPC + KP - 1
+            DO 40 J = KP + 1, K - 1
+               KX = KX + J - 1
+               TEMP = AP( KC+J-1 )
+               AP( KC+J-1 ) = AP( KX )
+               AP( KX ) = TEMP
+   40       CONTINUE
+            TEMP = AP( KC+K-1 )
+            AP( KC+K-1 ) = AP( KPC+KP-1 )
+            AP( KPC+KP-1 ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC+K+K-1 )
+               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+               AP( KC+K+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         KC = KCNEXT
+         GO TO 30
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         NPP = N*( N+1 ) / 2
+         K = N
+         KC = NPP
+   60    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 80
+*
+         KCNEXT = KC - ( N-K+2 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            AP( KC ) = ONE / AP( KC )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL ZSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - ZDOTU( N-K, WORK, 1, AP( KC+1 ),
+     $                    1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = AP( KCNEXT+1 )
+            AK = AP( KCNEXT ) / T
+            AKP1 = AP( KC ) / T
+            AKKP1 = AP( KCNEXT+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            AP( KCNEXT ) = AKP1 / D
+            AP( KC ) = AK / D
+            AP( KCNEXT+1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL ZCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+               CALL ZSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KC+1 ), 1 )
+               AP( KC ) = AP( KC ) - ZDOTU( N-K, WORK, 1, AP( KC+1 ),
+     $                    1 )
+               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+     $                          ZDOTU( N-K, AP( KC+1 ), 1,
+     $                          AP( KCNEXT+2 ), 1 )
+               CALL ZCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+               CALL ZSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+     $                     ZERO, AP( KCNEXT+2 ), 1 )
+               AP( KCNEXT ) = AP( KCNEXT ) -
+     $                        ZDOTU( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
+            END IF
+            KSTEP = 2
+            KCNEXT = KCNEXT - ( N-K+3 )
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+            IF( KP.LT.N )
+     $         CALL ZSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+            KX = KC + KP - K
+            DO 70 J = K + 1, KP - 1
+               KX = KX + N - J + 1
+               TEMP = AP( KC+J-K )
+               AP( KC+J-K ) = AP( KX )
+               AP( KX ) = TEMP
+   70       CONTINUE
+            TEMP = AP( KC )
+            AP( KC ) = AP( KPC )
+            AP( KPC ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = AP( KC-N+K-1 )
+               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+               AP( KC-N+KP-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         KC = KCNEXT
+         GO TO 60
+   80    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZSPTRI
+*
+      END
diff --git a/SRC/zsptrs.f b/SRC/zsptrs.f
new file mode 100644
index 00000000..a76a456c
--- /dev/null
+++ b/SRC/zsptrs.f
@@ -0,0 +1,377 @@
+      SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSPTRS solves a system of linear equations A*X = B with a complex
+*  symmetric matrix A stored in packed format using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZSPTRF, stored as a
+*          packed triangular matrix.
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZSPTRF.
+*
+*  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            UPPER
+      INTEGER            J, K, KC, KP
+      COMPLEX*16         AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSPTRS', -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
+         KC = N*( N+1 ) / 2 + 1
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         KC = KC - K
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL ZSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K-1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K-1 )
+     $         CALL ZSWAP( 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 ZGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL ZGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+     $                  B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+K-2 )
+            AKM1 = AP( KC-1 ) / AKM1K
+            AK = AP( KC+K-1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / AKM1K
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            KC = KC - K + 1
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + K
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+     $                  AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC + 2*K + 1
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+         KC = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+     $                     LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL ZSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
+            KC = KC + N - K + 1
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL ZSWAP( 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 ZGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+     $                     B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = AP( KC+1 )
+            AKM1 = AP( KC ) / AKM1K
+            AK = AP( KC+N-K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / AKM1K
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            KC = KC + 2*( N-K ) + 1
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+         KC = N*( N+1 ) / 2 + 1
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         KC = KC - ( N-K+1 )
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( 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 ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+               CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
+     $                     LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            KC = KC - ( N-K+2 )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZSPTRS
+*
+      END
diff --git a/SRC/zstedc.f b/SRC/zstedc.f
new file mode 100644
index 00000000..88be1d31
--- /dev/null
+++ b/SRC/zstedc.f
@@ -0,0 +1,404 @@
+      SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK,
+     $                   LRWORK, IWORK, LIWORK, 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, LIWORK, LRWORK, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
+      COMPLEX*16         WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric tridiagonal matrix using the divide and conquer 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.
+*
+*  This code makes very mild assumptions about floating point
+*  arithmetic. It will work on machines with a guard digit in
+*  add/subtract, or on those binary machines without guard digits
+*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+*  It could conceivably fail on hexadecimal or decimal machines
+*  without guard digits, but we know of none.  See DLAED3 for details.
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'I':  Compute eigenvectors of tridiagonal matrix also.
+*          = 'V':  Compute eigenvectors of original Hermitian matrix
+*                  also.  On entry, Z contains the unitary matrix used
+*                  to reduce the original matrix to tridiagonal form.
+*
+*  N       (input) INTEGER
+*          The dimension of the symmetric tridiagonal 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 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.
+*          If eigenvectors are desired, then LDZ >= max(1,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.
+*          If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
+*          Note that for COMPZ = 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LWORK need
+*          only be 1.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal sizes of the WORK, RWORK and
+*          IWORK arrays, returns these values as the first entries of
+*          the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array,
+*                                         dimension (LRWORK)
+*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*
+*  LRWORK  (input) INTEGER
+*          The dimension of the array RWORK.
+*          If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
+*          If COMPZ = 'V' and N > 1, LRWORK must be at least
+*                         1 + 3*N + 2*N*lg N + 3*N**2 ,
+*                         where lg( N ) = smallest integer k such
+*                         that 2**k >= N.
+*          If COMPZ = 'I' and N > 1, LRWORK must be at least
+*                         1 + 4*N + 2*N**2 .
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LRWORK
+*          need only be max(1,2*(N-1)).
+*
+*          If LRWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK is 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.
+*          If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
+*          If COMPZ = 'V' or N > 1,  LIWORK must be at least
+*                                    6 + 6*N + 5*N*lg N.
+*          If COMPZ = 'I' or N > 1,  LIWORK must be at least
+*                                    3 + 5*N .
+*          Note that for COMPZ = 'I' or 'V', then if N is less than or
+*          equal to the minimum divide size, usually 25, then LIWORK
+*          need only be 1.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal sizes of the WORK, RWORK
+*          and IWORK arrays, returns these values as the first entries
+*          of the WORK, RWORK and IWORK arrays, and no error message
+*          related to LWORK or LRWORK or LIWORK 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 failed to compute an eigenvalue while
+*                working on the submatrix lying in rows and columns
+*                INFO/(N+1) through mod(INFO,N+1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Jeff Rutter, Computer Science Division, University of California
+*     at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL,
+     $                   LRWMIN, LWMIN, M, SMLSIZ, START
+      DOUBLE PRECISION   EPS, ORGNRM, P, TINY
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA,
+     $                   ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG, MAX, MOD, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR.
+     $         ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Compute the workspace requirements
+*
+         SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 )
+         IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 1
+         ELSE IF( N.LE.SMLSIZ ) THEN
+            LWMIN = 1
+            LIWMIN = 1
+            LRWMIN = 2*( N - 1 )
+         ELSE IF( ICOMPZ.EQ.1 ) THEN
+            LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            IF( 2**LGN.LT.N )
+     $         LGN = LGN + 1
+            LWMIN = N*N
+            LRWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
+            LIWMIN = 6 + 6*N + 5*N*LGN
+         ELSE IF( ICOMPZ.EQ.2 ) THEN
+            LWMIN = 1
+            LRWMIN = 1 + 4*N + 2*N**2
+            LIWMIN = 3 + 5*N
+         END IF
+         WORK( 1 ) = LWMIN
+         RWORK( 1 ) = LRWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -10
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSTEDC', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.NE.0 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     If the following conditional clause is removed, then the routine
+*     will use the Divide and Conquer routine to compute only the
+*     eigenvalues, which requires (3N + 3N**2) real workspace and
+*     (2 + 5N + 2N lg(N)) integer workspace.
+*     Since on many architectures DSTERF is much faster than any other
+*     algorithm for finding eigenvalues only, it is used here
+*     as the default. If the conditional clause is removed, then
+*     information on the size of workspace needs to be changed.
+*
+*     If COMPZ = 'N', use DSTERF to compute the eigenvalues.
+*
+      IF( ICOMPZ.EQ.0 ) THEN
+         CALL DSTERF( N, D, E, INFO )
+         GO TO 70
+      END IF
+*
+*     If N is smaller than the minimum divide size (SMLSIZ+1), then
+*     solve the problem with another solver.
+*
+      IF( N.LE.SMLSIZ ) THEN
+*
+         CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO )
+*
+      ELSE
+*
+*        If COMPZ = 'I', we simply call DSTEDC instead.
+*
+         IF( ICOMPZ.EQ.2 ) THEN
+            CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N )
+            LL = N*N + 1
+            CALL DSTEDC( 'I', N, D, E, RWORK, N,
+     $                   RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO )
+            DO 20 J = 1, N
+               DO 10 I = 1, N
+                  Z( I, J ) = RWORK( ( J-1 )*N+I )
+   10          CONTINUE
+   20       CONTINUE
+            GO TO 70
+         END IF
+*
+*        From now on, only option left to be handled is COMPZ = 'V',
+*        i.e. ICOMPZ = 1.
+*
+*        Scale.
+*
+         ORGNRM = DLANST( 'M', N, D, E )
+         IF( ORGNRM.EQ.ZERO )
+     $      GO TO 70
+*
+         EPS = DLAMCH( 'Epsilon' )
+*
+         START = 1
+*
+*        while ( START <= N )
+*
+   30    CONTINUE
+         IF( START.LE.N ) THEN
+*
+*           Let FINISH be the position of the next subdiagonal entry
+*           such that E( FINISH ) <= TINY or FINISH = N if no such
+*           subdiagonal exists.  The matrix identified by the elements
+*           between START and FINISH constitutes an independent
+*           sub-problem.
+*
+            FINISH = START
+   40       CONTINUE
+            IF( FINISH.LT.N ) THEN
+               TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
+     $                    SQRT( ABS( D( FINISH+1 ) ) )
+               IF( ABS( E( FINISH ) ).GT.TINY ) THEN
+                  FINISH = FINISH + 1
+                  GO TO 40
+               END IF
+            END IF
+*
+*           (Sub) Problem determined.  Compute its size and solve it.
+*
+            M = FINISH - START + 1
+            IF( M.GT.SMLSIZ ) THEN
+*
+*              Scale.
+*
+               ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
+               CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
+     $                      INFO )
+               CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
+     $                      M-1, INFO )
+*
+               CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ),
+     $                      LDZ, WORK, N, RWORK, IWORK, INFO )
+               IF( INFO.GT.0 ) THEN
+                  INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
+     $                   MOD( INFO, ( M+1 ) ) + START - 1
+                  GO TO 70
+               END IF
+*
+*              Scale back.
+*
+               CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
+     $                      INFO )
+*
+            ELSE
+               CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M,
+     $                      RWORK( M*M+1 ), INFO )
+               CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N,
+     $                      RWORK( M*M+1 ) )
+               CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ )
+               IF( INFO.GT.0 ) THEN
+                  INFO = START*( N+1 ) + FINISH
+                  GO TO 70
+               END IF
+            END IF
+*
+            START = FINISH + 1
+            GO TO 30
+         END IF
+*
+*        endwhile
+*
+*        If the problem split any number of times, then the eigenvalues
+*        will not be properly ordered.  Here we permute the eigenvalues
+*        (and the associated eigenvectors) into ascending order.
+*
+         IF( M.NE.N ) THEN
+*
+*           Use Selection Sort to minimize swaps of eigenvectors
+*
+            DO 60 II = 2, N
+               I = II - 1
+               K = I
+               P = D( I )
+               DO 50 J = II, N
+                  IF( D( J ).LT.P ) THEN
+                     K = J
+                     P = D( J )
+                  END IF
+   50          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
+   60       CONTINUE
+         END IF
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = LWMIN
+      RWORK( 1 ) = LRWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of ZSTEDC
+*
+      END
diff --git a/SRC/zstegr.f b/SRC/zstegr.f
new file mode 100644
index 00000000..597c8ff5
--- /dev/null
+++ b/SRC/zstegr.f
@@ -0,0 +1,180 @@
+      SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $           ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+     $           LIWORK, INFO )
+
+      IMPLICIT NONE
+*
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+      DOUBLE PRECISION ABSTOL, VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
+      COMPLEX*16         Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSTEGR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  ZSTEGR is a compatability wrapper around the improved ZSTEMR routine.
+*  See DSTEMR for further details.
+*
+*  One important change is that the ABSTOL parameter no longer provides any
+*  benefit and hence is no longer used.
+*
+*  Note : ZSTEGR and ZSTEMR work only on machines which follow
+*  IEEE-754 floating-point standard in their handling of infinities and
+*  NaNs.  Normal execution may create these exceptiona values and hence
+*  may abort due to a floating point exception in environments which
+*  do not conform to the IEEE-754 standard.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  ABSTOL  (input) DOUBLE PRECISION
+*          Unused.  Was the absolute error tolerance for the
+*          eigenvalues/eigenvectors in previous versions.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and an upper bound must be used.
+*          Supplying N columns is always safe.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in DLARRE,
+*                if INFO = 2X, internal error in ZLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by DLARRE or
+*                ZLARRV, respectively.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Inderjit Dhillon, IBM Almaden, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, LBNL/NERSC, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL TRYRAC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL ZSTEMR
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+      TRYRAC = .FALSE.
+
+      CALL ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+*
+*     End of ZSTEGR
+*
+      END
diff --git a/SRC/zstein.f b/SRC/zstein.f
new file mode 100644
index 00000000..615066af
--- /dev/null
+++ b/SRC/zstein.f
@@ -0,0 +1,376 @@
+      SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
+     $                   IWORK, IFAIL, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDZ, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
+     $                   IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
+      COMPLEX*16         Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSTEIN computes the eigenvectors of a real symmetric tridiagonal
+*  matrix T corresponding to specified eigenvalues, using inverse
+*  iteration.
+*
+*  The maximum number of iterations allowed for each eigenvector is
+*  specified by an internal parameter MAXITS (currently set to 5).
+*
+*  Although the eigenvectors are real, they are stored in a complex
+*  array, which may be passed to ZUNMTR or ZUPMTR for back
+*  transformation to the eigenvectors of a complex Hermitian matrix
+*  which was reduced to tridiagonal form.
+*
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The n diagonal elements of the tridiagonal matrix T.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) subdiagonal elements of the tridiagonal matrix
+*          T, stored in elements 1 to N-1.
+*
+*  M       (input) INTEGER
+*          The number of eigenvectors to be found.  0 <= M <= N.
+*
+*  W       (input) DOUBLE PRECISION array, dimension (N)
+*          The first M elements of W contain the eigenvalues for
+*          which eigenvectors are to be computed.  The eigenvalues
+*          should be grouped by split-off block and ordered from
+*          smallest to largest within the block.  ( The output array
+*          W from DSTEBZ with ORDER = 'B' is expected here. )
+*
+*  IBLOCK  (input) INTEGER array, dimension (N)
+*          The submatrix indices associated with the corresponding
+*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
+*          the first submatrix from the top, =2 if W(i) belongs to
+*          the second submatrix, etc.  ( The output array IBLOCK
+*          from DSTEBZ is expected here. )
+*
+*  ISPLIT  (input) INTEGER array, dimension (N)
+*          The splitting points, at which T breaks up into submatrices.
+*          The first submatrix consists of rows/columns 1 to
+*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+*          through ISPLIT( 2 ), etc.
+*          ( The output array ISPLIT from DSTEBZ is expected here. )
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, M)
+*          The computed eigenvectors.  The eigenvector associated
+*          with the eigenvalue W(i) is stored in the i-th column of
+*          Z.  Any vector which fails to converge is set to its current
+*          iterate after MAXITS iterations.
+*          The imaginary parts of the eigenvectors are set to zero.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  IFAIL   (output) INTEGER array, dimension (M)
+*          On normal exit, all elements of IFAIL are zero.
+*          If one or more eigenvectors fail to converge after
+*          MAXITS iterations, then their indices are stored in
+*          array IFAIL.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, then i eigenvectors failed to converge
+*               in MAXITS iterations.  Their indices are stored in
+*               array IFAIL.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXITS  INTEGER, default = 5
+*          The maximum number of iterations performed.
+*
+*  EXTRA   INTEGER, default = 2
+*          The number of iterations performed after norm growth
+*          criterion is satisfied, should be at least 1.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   ZERO, ONE, TEN, ODM3, ODM1
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
+     $                   ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
+      INTEGER            MAXITS, EXTRA
+      PARAMETER          ( MAXITS = 5, EXTRA = 2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
+     $                   INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
+     $                   JBLK, JMAX, JR, NBLK, NRMCHK
+      DOUBLE PRECISION   DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
+     $                   SCL, SEP, TOL, XJ, XJM, ZTR
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISEED( 4 )
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DLAMCH, DNRM2
+      EXTERNAL           IDAMAX, DASUM, DLAMCH, DNRM2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      DO 10 I = 1, M
+         IFAIL( I ) = 0
+   10 CONTINUE
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE
+         DO 20 J = 2, M
+            IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
+               INFO = -6
+               GO TO 30
+            END IF
+            IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
+     $           THEN
+               INFO = -5
+               GO TO 30
+            END IF
+   20    CONTINUE
+   30    CONTINUE
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSTEIN', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      EPS = DLAMCH( 'Precision' )
+*
+*     Initialize seed for random number generator DLARNV.
+*
+      DO 40 I = 1, 4
+         ISEED( I ) = 1
+   40 CONTINUE
+*
+*     Initialize pointers.
+*
+      INDRV1 = 0
+      INDRV2 = INDRV1 + N
+      INDRV3 = INDRV2 + N
+      INDRV4 = INDRV3 + N
+      INDRV5 = INDRV4 + N
+*
+*     Compute eigenvectors of matrix blocks.
+*
+      J1 = 1
+      DO 180 NBLK = 1, IBLOCK( M )
+*
+*        Find starting and ending indices of block nblk.
+*
+         IF( NBLK.EQ.1 ) THEN
+            B1 = 1
+         ELSE
+            B1 = ISPLIT( NBLK-1 ) + 1
+         END IF
+         BN = ISPLIT( NBLK )
+         BLKSIZ = BN - B1 + 1
+         IF( BLKSIZ.EQ.1 )
+     $      GO TO 60
+         GPIND = B1
+*
+*        Compute reorthogonalization criterion and stopping criterion.
+*
+         ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
+         ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
+         DO 50 I = B1 + 1, BN - 1
+            ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
+     $               ABS( E( I ) ) )
+   50    CONTINUE
+         ORTOL = ODM3*ONENRM
+*
+         DTPCRT = SQRT( ODM1 / BLKSIZ )
+*
+*        Loop through eigenvalues of block nblk.
+*
+   60    CONTINUE
+         JBLK = 0
+         DO 170 J = J1, M
+            IF( IBLOCK( J ).NE.NBLK ) THEN
+               J1 = J
+               GO TO 180
+            END IF
+            JBLK = JBLK + 1
+            XJ = W( J )
+*
+*           Skip all the work if the block size is one.
+*
+            IF( BLKSIZ.EQ.1 ) THEN
+               WORK( INDRV1+1 ) = ONE
+               GO TO 140
+            END IF
+*
+*           If eigenvalues j and j-1 are too close, add a relatively
+*           small perturbation.
+*
+            IF( JBLK.GT.1 ) THEN
+               EPS1 = ABS( EPS*XJ )
+               PERTOL = TEN*EPS1
+               SEP = XJ - XJM
+               IF( SEP.LT.PERTOL )
+     $            XJ = XJM + PERTOL
+            END IF
+*
+            ITS = 0
+            NRMCHK = 0
+*
+*           Get random starting vector.
+*
+            CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
+*
+*           Copy the matrix T so it won't be destroyed in factorization.
+*
+            CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
+            CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
+            CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
+*
+*           Compute LU factors with partial pivoting  ( PT = LU )
+*
+            TOL = ZERO
+            CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
+     $                   IINFO )
+*
+*           Update iteration count.
+*
+   70       CONTINUE
+            ITS = ITS + 1
+            IF( ITS.GT.MAXITS )
+     $         GO TO 120
+*
+*           Normalize and scale the righthand side vector Pb.
+*
+            SCL = BLKSIZ*ONENRM*MAX( EPS,
+     $            ABS( WORK( INDRV4+BLKSIZ ) ) ) /
+     $            DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+*
+*           Solve the system LU = Pb.
+*
+            CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
+     $                   WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
+     $                   WORK( INDRV1+1 ), TOL, IINFO )
+*
+*           Reorthogonalize by modified Gram-Schmidt if eigenvalues are
+*           close enough.
+*
+            IF( JBLK.EQ.1 )
+     $         GO TO 110
+            IF( ABS( XJ-XJM ).GT.ORTOL )
+     $         GPIND = J
+            IF( GPIND.NE.J ) THEN
+               DO 100 I = GPIND, J - 1
+                  ZTR = ZERO
+                  DO 80 JR = 1, BLKSIZ
+                     ZTR = ZTR + WORK( INDRV1+JR )*
+     $                     DBLE( Z( B1-1+JR, I ) )
+   80             CONTINUE
+                  DO 90 JR = 1, BLKSIZ
+                     WORK( INDRV1+JR ) = WORK( INDRV1+JR ) -
+     $                                   ZTR*DBLE( Z( B1-1+JR, I ) )
+   90             CONTINUE
+  100          CONTINUE
+            END IF
+*
+*           Check the infinity norm of the iterate.
+*
+  110       CONTINUE
+            JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            NRM = ABS( WORK( INDRV1+JMAX ) )
+*
+*           Continue for additional iterations after norm reaches
+*           stopping criterion.
+*
+            IF( NRM.LT.DTPCRT )
+     $         GO TO 70
+            NRMCHK = NRMCHK + 1
+            IF( NRMCHK.LT.EXTRA+1 )
+     $         GO TO 70
+*
+            GO TO 130
+*
+*           If stopping criterion was not satisfied, update info and
+*           store eigenvector number in array ifail.
+*
+  120       CONTINUE
+            INFO = INFO + 1
+            IFAIL( INFO ) = J
+*
+*           Accept iterate as jth eigenvector.
+*
+  130       CONTINUE
+            SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+            IF( WORK( INDRV1+JMAX ).LT.ZERO )
+     $         SCL = -SCL
+            CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+  140       CONTINUE
+            DO 150 I = 1, N
+               Z( I, J ) = CZERO
+  150       CONTINUE
+            DO 160 I = 1, BLKSIZ
+               Z( B1+I-1, J ) = DCMPLX( WORK( INDRV1+I ), ZERO )
+  160       CONTINUE
+*
+*           Save the shift to check eigenvalue spacing at next
+*           iteration.
+*
+            XJM = XJ
+*
+  170    CONTINUE
+  180 CONTINUE
+*
+      RETURN
+*
+*     End of ZSTEIN
+*
+      END
diff --git a/SRC/zstemr.f b/SRC/zstemr.f
new file mode 100644
index 00000000..ea94ce71
--- /dev/null
+++ b/SRC/zstemr.f
@@ -0,0 +1,663 @@
+      SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+     $                   M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
+     $                   IWORK, LIWORK, INFO )
+      IMPLICIT NONE
+*
+*  -- LAPACK computational routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, RANGE
+      LOGICAL            TRYRAC
+      INTEGER            IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
+      DOUBLE PRECISION VL, VU
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISUPPZ( * ), IWORK( * )
+      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
+      COMPLEX*16         Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSTEMR computes selected eigenvalues and, optionally, eigenvectors
+*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+*  a well defined set of pairwise different real eigenvalues, the corresponding
+*  real eigenvectors are pairwise orthogonal.
+*
+*  The spectrum may be computed either completely or partially by specifying
+*  either an interval (VL,VU] or a range of indices IL:IU for the desired
+*  eigenvalues.
+*
+*  Depending on the number of desired eigenvalues, these are computed either
+*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
+*  computed by the use of various suitable L D L^T factorizations near clusters
+*  of close eigenvalues (referred to as RRRs, Relatively Robust
+*  Representations). An informal sketch of the algorithm follows.
+*
+*  For each unreduced block (submatrix) of T,
+*     (a) Compute T - sigma I  = L D L^T, so that L and D
+*         define all the wanted eigenvalues to high relative accuracy.
+*         This means that small relative changes in the entries of D and L
+*         cause only small relative changes in the eigenvalues and
+*         eigenvectors. The standard (unfactored) representation of the
+*         tridiagonal matrix T does not have this property in general.
+*     (b) Compute the eigenvalues to suitable accuracy.
+*         If the eigenvectors are desired, the algorithm attains full
+*         accuracy of the computed eigenvalues only right before
+*         the corresponding vectors have to be computed, see steps c) and d).
+*     (c) For each cluster of close eigenvalues, select a new
+*         shift close to the cluster, find a new factorization, and refine
+*         the shifted eigenvalues to suitable accuracy.
+*     (d) For each eigenvalue with a large enough relative separation compute
+*         the corresponding eigenvector by forming a rank revealing twisted
+*         factorization. Go back to (c) for any clusters that remain.
+*
+*  For more details, see:
+*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+*    2004.  Also LAPACK Working Note 154.
+*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+*    tridiagonal eigenvalue/eigenvector problem",
+*    Computer Science Division Technical Report No. UCB/CSD-97-971,
+*    UC Berkeley, May 1997.
+*
+*  Notes:
+*  1.ZSTEMR works only on machines which follow IEEE-754
+*  floating-point standard in their handling of infinities and NaNs.
+*  This permits the use of efficient inner loops avoiding a check for
+*  zero divisors.
+*
+*  2. LAPACK routines can be used to reduce a complex Hermitean matrix to
+*  real symmetric tridiagonal form.
+*
+*  (Any complex Hermitean tridiagonal matrix has real values on its diagonal
+*  and potentially complex numbers on its off-diagonals. By applying a
+*  similarity transform with an appropriate diagonal matrix
+*  diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
+*  matrix can be transformed into a real symmetric matrix and complex
+*  arithmetic can be entirely avoided.)
+*
+*  While the eigenvectors of the real symmetric tridiagonal matrix are real,
+*  the eigenvectors of original complex Hermitean matrix have complex entries
+*  in general.
+*  Since LAPACK drivers overwrite the matrix data with the eigenvectors,
+*  ZSTEMR accepts complex workspace to facilitate interoperability
+*  with ZUNMTR or ZUPMTR.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  RANGE   (input) CHARACTER*1
+*          = 'A': all eigenvalues will be found.
+*          = 'V': all eigenvalues in the half-open interval (VL,VU]
+*                 will be found.
+*          = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the N diagonal elements of the tridiagonal matrix
+*          T. On exit, D is overwritten.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the (N-1) subdiagonal elements of the tridiagonal
+*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
+*          input, but is used internally as workspace.
+*          On exit, E is overwritten.
+*
+*  VL      (input) DOUBLE PRECISION
+*  VU      (input) DOUBLE PRECISION
+*          If RANGE='V', the lower and upper bounds of the interval to
+*          be searched for eigenvalues. VL < VU.
+*          Not referenced if RANGE = 'A' or 'I'.
+*
+*  IL      (input) INTEGER
+*  IU      (input) INTEGER
+*          If RANGE='I', the indices (in ascending order) of the
+*          smallest and largest eigenvalues to be returned.
+*          1 <= IL <= IU <= N, if N > 0.
+*          Not referenced if RANGE = 'A' or 'V'.
+*
+*  M       (output) INTEGER
+*          The total number of eigenvalues found.  0 <= M <= N.
+*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          The first M elements contain the selected eigenvalues in
+*          ascending order.
+*
+*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )
+*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+*          contain the orthonormal eigenvectors of the matrix T
+*          corresponding to the selected eigenvalues, with the i-th
+*          column of Z holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*          Note: the user must ensure that at least max(1,M) columns are
+*          supplied in the array Z; if RANGE = 'V', the exact value of M
+*          is not known in advance and can be computed with a workspace
+*          query by setting NZC = -1, see below.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', then LDZ >= max(1,N).
+*
+*  NZC     (input) INTEGER
+*          The number of eigenvectors to be held in the array Z.
+*          If RANGE = 'A', then NZC >= max(1,N).
+*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+*          If RANGE = 'I', then NZC >= IU-IL+1.
+*          If NZC = -1, then a workspace query is assumed; the
+*          routine calculates the number of columns of the array Z that
+*          are needed to hold the eigenvectors.
+*          This value is returned as the first entry of the Z array, and
+*          no error message related to NZC is issued by XERBLA.
+*
+*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+*          The support of the eigenvectors in Z, i.e., the indices
+*          indicating the nonzero elements in Z. The i-th computed eigenvector
+*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
+*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
+*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+*  TRYRAC  (input/output) LOGICAL
+*          If TRYRAC.EQ..TRUE., indicates that the code should check whether
+*          the tridiagonal matrix defines its eigenvalues to high relative
+*          accuracy.  If so, the code uses relative-accuracy preserving
+*          algorithms that might be (a bit) slower depending on the matrix.
+*          If the matrix does not define its eigenvalues to high relative
+*          accuracy, the code can uses possibly faster algorithms.
+*          If TRYRAC.EQ..FALSE., the code is not required to guarantee
+*          relatively accurate eigenvalues and can use the fastest possible
+*          techniques.
+*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
+*          does not define its eigenvalues to high relative accuracy.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal
+*          (and minimal) LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,18*N)
+*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
+*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+*          if only the eigenvalues are to be computed.
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = 1X, internal error in DLARRE,
+*                if INFO = 2X, internal error in ZLARRV.
+*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+*                the nonzero error code returned by DLARRE or
+*                ZLARRV, respectively.
+*
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Beresford Parlett, University of California, Berkeley, USA
+*     Jim Demmel, University of California, Berkeley, USA
+*     Inderjit Dhillon, University of Texas, Austin, USA
+*     Osni Marques, LBNL/NERSC, USA
+*     Christof Voemel, University of California, Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, FOUR, MINRGP
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0,
+     $                     FOUR = 4.0D0,
+     $                     MINRGP = 1.0D-3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+      INTEGER            I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
+     $                   IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
+     $                   INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
+     $                   ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
+     $                   NZCMIN, OFFSET, WBEGIN, WEND
+      DOUBLE PRECISION   BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
+     $                   RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
+     $                   THRESH, TMP, TNRM, WL, WU
+*     ..
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST
+      EXTERNAL           LSAME, DLAMCH, DLANST
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ,
+     $                   DLARRR, DLASRT, DSCAL, XERBLA, ZLARRV, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+
+
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      ALLEIG = LSAME( RANGE, 'A' )
+      VALEIG = LSAME( RANGE, 'V' )
+      INDEIG = LSAME( RANGE, 'I' )
+*
+      LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+      ZQUERY = ( NZC.EQ.-1 )
+
+*     DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
+*     In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
+*     Furthermore, ZLARRV needs WORK of size 12*N, IWORK of size 7*N.
+      IF( WANTZ ) THEN
+         LWMIN = 18*N
+         LIWMIN = 10*N
+      ELSE
+*        need less workspace if only the eigenvalues are wanted
+         LWMIN = 12*N
+         LIWMIN = 8*N
+      ENDIF
+
+      WL = ZERO
+      WU = ZERO
+      IIL = 0
+      IIU = 0
+
+      IF( VALEIG ) THEN
+*        We do not reference VL, VU in the cases RANGE = 'I','A'
+*        The interval (WL, WU] contains all the wanted eigenvalues.
+*        It is either given by the user or computed in DLARRE.
+         WL = VL
+         WU = VU
+      ELSEIF( INDEIG ) THEN
+*        We do not reference IL, IU in the cases RANGE = 'V','A'
+         IIL = IL
+         IIU = IU
+      ENDIF
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
+         INFO = -7
+      ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
+         INFO = -8
+      ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -17
+      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -19
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+*
+         IF( WANTZ .AND. ALLEIG ) THEN
+            NZCMIN = N
+         ELSE IF( WANTZ .AND. VALEIG ) THEN
+            CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+     $                            NZCMIN, ITMP, ITMP2, INFO )
+         ELSE IF( WANTZ .AND. INDEIG ) THEN
+            NZCMIN = IIU-IIL+1
+         ELSE
+*           WANTZ .EQ. FALSE.
+            NZCMIN = 0
+         ENDIF
+         IF( ZQUERY .AND. INFO.EQ.0 ) THEN
+            Z( 1,1 ) = NZCMIN
+         ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
+            INFO = -14
+         END IF
+      END IF
+
+      IF( INFO.NE.0 ) THEN
+*
+         CALL XERBLA( 'ZSTEMR', -INFO )
+*
+         RETURN
+      ELSE IF( LQUERY .OR. ZQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Handle N = 0, 1, and 2 cases immediately
+*
+      M = 0
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ALLEIG .OR. INDEIG ) THEN
+            M = 1
+            W( 1 ) = D( 1 )
+         ELSE
+            IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+               M = 1
+               W( 1 ) = D( 1 )
+            END IF
+         END IF
+         IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            Z( 1, 1 ) = ONE
+            ISUPPZ(1) = 1
+            ISUPPZ(2) = 1
+         END IF
+         RETURN
+      END IF
+*
+      IF( N.EQ.2 ) THEN
+         IF( .NOT.WANTZ ) THEN
+            CALL DLAE2( D(1), E(1), D(2), R1, R2 )
+         ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+            CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
+         END IF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R2.GT.WL).AND.
+     $                  (R2.LE.WU)).OR.
+     $      (INDEIG.AND.(IIL.EQ.1)) ) THEN
+            M = M+1
+            W( M ) = R2
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = -SN
+               Z( 2, M ) = CS
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         IF( ALLEIG.OR.
+     $      (VALEIG.AND.(R1.GT.WL).AND.
+     $                  (R1.LE.WU)).OR.
+     $      (INDEIG.AND.(IIU.EQ.2)) ) THEN
+            M = M+1
+            W( M ) = R1
+            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+               Z( 1, M ) = CS
+               Z( 2, M ) = SN
+*              Note: At most one of SN and CS can be zero.
+               IF (SN.NE.ZERO) THEN
+                  IF (CS.NE.ZERO) THEN
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 2
+                  ELSE
+                     ISUPPZ(2*M-1) = 1
+                     ISUPPZ(2*M-1) = 1
+                  END IF
+               ELSE
+                  ISUPPZ(2*M-1) = 2
+                  ISUPPZ(2*M) = 2
+               END IF
+            ENDIF
+         ENDIF
+         RETURN
+      END IF
+
+*     Continue with general N
+
+      INDGRS = 1
+      INDERR = 2*N + 1
+      INDGP = 3*N + 1
+      INDD = 4*N + 1
+      INDE2 = 5*N + 1
+      INDWRK = 6*N + 1
+*
+      IINSPL = 1
+      IINDBL = N + 1
+      IINDW = 2*N + 1
+      IINDWK = 3*N + 1
+*
+*     Scale matrix to allowable range, if necessary.
+*     The allowable range is related to the PIVMIN parameter; see the
+*     comments in DLARRD.  The preference for scaling small values
+*     up is heuristic; we expect users' matrices not to be close to the
+*     RMAX threshold.
+*
+      SCALE = ONE
+      TNRM = DLANST( 'M', N, D, E )
+      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+         SCALE = RMIN / TNRM
+      ELSE IF( TNRM.GT.RMAX ) THEN
+         SCALE = RMAX / TNRM
+      END IF
+      IF( SCALE.NE.ONE ) THEN
+         CALL DSCAL( N, SCALE, D, 1 )
+         CALL DSCAL( N-1, SCALE, E, 1 )
+         TNRM = TNRM*SCALE
+         IF( VALEIG ) THEN
+*           If eigenvalues in interval have to be found,
+*           scale (WL, WU] accordingly
+            WL = WL*SCALE
+            WU = WU*SCALE
+         ENDIF
+      END IF
+*
+*     Compute the desired eigenvalues of the tridiagonal after splitting
+*     into smaller subblocks if the corresponding off-diagonal elements
+*     are small
+*     THRESH is the splitting parameter for DLARRE
+*     A negative THRESH forces the old splitting criterion based on the
+*     size of the off-diagonal. A positive THRESH switches to splitting
+*     which preserves relative accuracy.
+*
+      IF( TRYRAC ) THEN
+*        Test whether the matrix warrants the more expensive relative approach.
+         CALL DLARRR( N, D, E, IINFO )
+      ELSE
+*        The user does not care about relative accurately eigenvalues
+         IINFO = -1
+      ENDIF
+*     Set the splitting criterion
+      IF (IINFO.EQ.0) THEN
+         THRESH = EPS
+      ELSE
+         THRESH = -EPS
+*        relative accuracy is desired but T does not guarantee it
+         TRYRAC = .FALSE.
+      ENDIF
+*
+      IF( TRYRAC ) THEN
+*        Copy original diagonal, needed to guarantee relative accuracy
+         CALL DCOPY(N,D,1,WORK(INDD),1)
+      ENDIF
+*     Store the squares of the offdiagonal values of T
+      DO 5 J = 1, N-1
+         WORK( INDE2+J-1 ) = E(J)**2
+ 5    CONTINUE
+
+*     Set the tolerance parameters for bisection
+      IF( .NOT.WANTZ ) THEN
+*        DLARRE computes the eigenvalues to full precision.
+         RTOL1 = FOUR * EPS
+         RTOL2 = FOUR * EPS
+      ELSE
+*        DLARRE computes the eigenvalues to less than full precision.
+*        ZLARRV will refine the eigenvalue approximations, and we only
+*        need less accurate initial bisection in DLARRE.
+*        Note: these settings do only affect the subset case and DLARRE
+         RTOL1 = SQRT(EPS)
+         RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
+      ENDIF
+      CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
+     $             WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+     $             IWORK( IINSPL ), M, W, WORK( INDERR ),
+     $             WORK( INDGP ), IWORK( IINDBL ),
+     $             IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+     $             WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = 10 + ABS( IINFO )
+         RETURN
+      END IF
+*     Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
+*     part of the spectrum. All desired eigenvalues are contained in
+*     (WL,WU]
+
+
+      IF( WANTZ ) THEN
+*
+*        Compute the desired eigenvectors corresponding to the computed
+*        eigenvalues
+*
+         CALL ZLARRV( N, WL, WU, D, E,
+     $                PIVMIN, IWORK( IINSPL ), M,
+     $                1, M, MINRGP, RTOL1, RTOL2,
+     $                W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+     $                IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
+     $                ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = 20 + ABS( IINFO )
+            RETURN
+         END IF
+      ELSE
+*        DLARRE computes eigenvalues of the (shifted) root representation
+*        ZLARRV returns the eigenvalues of the unshifted matrix.
+*        However, if the eigenvectors are not desired by the user, we need
+*        to apply the corresponding shifts from DLARRE to obtain the
+*        eigenvalues of the original matrix.
+         DO 20 J = 1, M
+            ITMP = IWORK( IINDBL+J-1 )
+            W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 20      CONTINUE
+      END IF
+*
+
+      IF ( TRYRAC ) THEN
+*        Refine computed eigenvalues so that they are relatively accurate
+*        with respect to the original matrix T.
+         IBEGIN = 1
+         WBEGIN = 1
+         DO 39  JBLK = 1, IWORK( IINDBL+M-1 )
+            IEND = IWORK( IINSPL+JBLK-1 )
+            IN = IEND - IBEGIN + 1
+            WEND = WBEGIN - 1
+*           check if any eigenvalues have to be refined in this block
+ 36         CONTINUE
+            IF( WEND.LT.M ) THEN
+               IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
+                  WEND = WEND + 1
+                  GO TO 36
+               END IF
+            END IF
+            IF( WEND.LT.WBEGIN ) THEN
+               IBEGIN = IEND + 1
+               GO TO 39
+            END IF
+
+            OFFSET = IWORK(IINDW+WBEGIN-1)-1
+            IFIRST = IWORK(IINDW+WBEGIN-1)
+            ILAST = IWORK(IINDW+WEND-1)
+            RTOL2 = FOUR * EPS
+            CALL DLARRJ( IN,
+     $                   WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
+     $                   IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
+     $                   WORK( INDERR+WBEGIN-1 ),
+     $                   WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
+     $                   TNRM, IINFO )
+            IBEGIN = IEND + 1
+            WBEGIN = WEND + 1
+ 39      CONTINUE
+      ENDIF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( SCALE.NE.ONE ) THEN
+         CALL DSCAL( M, ONE / SCALE, W, 1 )
+      END IF
+*
+*     If eigenvalues are not in increasing order, then sort them,
+*     possibly along with eigenvectors.
+*
+      IF( NSPLIT.GT.1 ) THEN
+         IF( .NOT. WANTZ ) THEN
+            CALL DLASRT( 'I', M, W, IINFO )
+            IF( IINFO.NE.0 ) THEN
+               INFO = 3
+               RETURN
+            END IF
+         ELSE
+            DO 60 J = 1, M - 1
+               I = 0
+               TMP = W( J )
+               DO 50 JJ = J + 1, M
+                  IF( W( JJ ).LT.TMP ) THEN
+                     I = JJ
+                     TMP = W( JJ )
+                  END IF
+ 50            CONTINUE
+               IF( I.NE.0 ) THEN
+                  W( I ) = W( J )
+                  W( J ) = TMP
+                  IF( WANTZ ) THEN
+                     CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+                     ITMP = ISUPPZ( 2*I-1 )
+                     ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
+                     ISUPPZ( 2*J-1 ) = ITMP
+                     ITMP = ISUPPZ( 2*I )
+                     ISUPPZ( 2*I ) = ISUPPZ( 2*J )
+                     ISUPPZ( 2*J ) = ITMP
+                  END IF
+               END IF
+ 60         CONTINUE
+         END IF
+      ENDIF
+*
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+      RETURN
+*
+*     End of ZSTEMR
+*
+      END
diff --git a/SRC/zsteqr.f b/SRC/zsteqr.f
new file mode 100644
index 00000000..a72fdd96
--- /dev/null
+++ b/SRC/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/zsycon.f b/SRC/zsycon.f
new file mode 100644
index 00000000..a9415423
--- /dev/null
+++ b/SRC/zsycon.f
@@ -0,0 +1,163 @@
+      SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+     $                   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          UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a complex symmetric matrix A using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZSYTRF.
+*
+*  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 ZSYTRF.
+*
+*  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) COMPLEX*16 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            UPPER
+      INTEGER            I, KASE
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACN2, ZSYTRS
+*     ..
+*     .. 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( 'ZSYCON', -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 ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL ZSYTRS( 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 ZSYCON
+*
+      END
diff --git a/SRC/zsymv.f b/SRC/zsymv.f
new file mode 100644
index 00000000..8d66ebe0
--- /dev/null
+++ b/SRC/zsymv.f
@@ -0,0 +1,264 @@
+      SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INCX, INCY, LDA, N
+      COMPLEX*16         ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYMV  performs the matrix-vector  operation
+*
+*     y := alpha*A*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are n element vectors and
+*  A is an n by n symmetric matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX*16
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A        (input) COMPLEX*16 array, dimension ( LDA, N )
+*           Before entry, with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced.
+*           Before entry, with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced.
+*           Unchanged on exit.
+*
+*  LDA      (input) INTEGER
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, N ).
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA     (input) COMPLEX*16
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y        (input/output) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y. On exit, Y is overwritten by the updated
+*           vector y.
+*
+*  INCY     (input) INTEGER
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
+      COMPLEX*16         TEMP1, TEMP2
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = 5
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 7
+      ELSE IF( INCY.EQ.0 ) THEN
+         INFO = 10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSYMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     Set up the start points in  X  and  Y.
+*
+      IF( INCX.GT.0 ) THEN
+         KX = 1
+      ELSE
+         KX = 1 - ( N-1 )*INCX
+      END IF
+      IF( INCY.GT.0 ) THEN
+         KY = 1
+      ELSE
+         KY = 1 - ( N-1 )*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+*     First form  y := beta*y.
+*
+      IF( BETA.NE.ONE ) THEN
+         IF( INCY.EQ.1 ) THEN
+            IF( BETA.EQ.ZERO ) THEN
+               DO 10 I = 1, N
+                  Y( I ) = ZERO
+   10          CONTINUE
+            ELSE
+               DO 20 I = 1, N
+                  Y( I ) = BETA*Y( I )
+   20          CONTINUE
+            END IF
+         ELSE
+            IY = KY
+            IF( BETA.EQ.ZERO ) THEN
+               DO 30 I = 1, N
+                  Y( IY ) = ZERO
+                  IY = IY + INCY
+   30          CONTINUE
+            ELSE
+               DO 40 I = 1, N
+                  Y( IY ) = BETA*Y( IY )
+                  IY = IY + INCY
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      IF( ALPHA.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  y  when A is stored in upper triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 60 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               DO 50 I = 1, J - 1
+                  Y( I ) = Y( I ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( I )
+   50          CONTINUE
+               Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2
+   60       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 80 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               IX = KX
+               IY = KY
+               DO 70 I = 1, J - 1
+                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( IX )
+                  IX = IX + INCX
+                  IY = IY + INCY
+   70          CONTINUE
+               Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+   80       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  y  when A is stored in lower triangle.
+*
+         IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN
+            DO 100 J = 1, N
+               TEMP1 = ALPHA*X( J )
+               TEMP2 = ZERO
+               Y( J ) = Y( J ) + TEMP1*A( J, J )
+               DO 90 I = J + 1, N
+                  Y( I ) = Y( I ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( I )
+   90          CONTINUE
+               Y( J ) = Y( J ) + ALPHA*TEMP2
+  100       CONTINUE
+         ELSE
+            JX = KX
+            JY = KY
+            DO 120 J = 1, N
+               TEMP1 = ALPHA*X( JX )
+               TEMP2 = ZERO
+               Y( JY ) = Y( JY ) + TEMP1*A( J, J )
+               IX = JX
+               IY = JY
+               DO 110 I = J + 1, N
+                  IX = IX + INCX
+                  IY = IY + INCY
+                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
+                  TEMP2 = TEMP2 + A( I, J )*X( IX )
+  110          CONTINUE
+               Y( JY ) = Y( JY ) + ALPHA*TEMP2
+               JX = JX + INCX
+               JY = JY + INCY
+  120       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZSYMV
+*
+      END
diff --git a/SRC/zsyr.f b/SRC/zsyr.f
new file mode 100644
index 00000000..f911b155
--- /dev/null
+++ b/SRC/zsyr.f
@@ -0,0 +1,198 @@
+      SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, 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            INCX, LDA, N
+      COMPLEX*16         ALPHA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYR   performs the symmetric rank 1 operation
+*
+*     A := alpha*x*( x' ) + A,
+*
+*  where alpha is a complex scalar, x is an n element vector and A is an
+*  n by n symmetric matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO     (input) CHARACTER*1
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA    (input) COMPLEX*16
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X        (input) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the N-
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  A        (input/output) COMPLEX*16 array, dimension ( LDA, N )
+*           Before entry, with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced. On exit, the
+*           upper triangular part of the array A is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry, with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced. On exit, the
+*           lower triangular part of the array A is overwritten by the
+*           lower triangular part of the updated matrix.
+*
+*  LDA      (input) INTEGER
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, N ).
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, IX, J, JX, KX
+      COMPLEX*16         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( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = 1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 ) THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = 7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSYR  ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Set the start point in X if the increment is not unity.
+*
+      IF( INCX.LE.0 ) THEN
+         KX = 1 - ( N-1 )*INCX
+      ELSE IF( INCX.NE.1 ) THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Form  A  when A is stored in upper triangle.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 20 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  DO 10 I = 1, J
+                     A( I, J ) = A( I, J ) + X( I )*TEMP
+   10             CONTINUE
+               END IF
+   20       CONTINUE
+         ELSE
+            JX = KX
+            DO 40 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  IX = KX
+                  DO 30 I = 1, J
+                     A( I, J ) = A( I, J ) + X( IX )*TEMP
+                     IX = IX + INCX
+   30             CONTINUE
+               END IF
+               JX = JX + INCX
+   40       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  A  when A is stored in lower triangle.
+*
+         IF( INCX.EQ.1 ) THEN
+            DO 60 J = 1, N
+               IF( X( J ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( J )
+                  DO 50 I = J, N
+                     A( I, J ) = A( I, J ) + X( I )*TEMP
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE
+            JX = KX
+            DO 80 J = 1, N
+               IF( X( JX ).NE.ZERO ) THEN
+                  TEMP = ALPHA*X( JX )
+                  IX = JX
+                  DO 70 I = J, N
+                     A( I, J ) = A( I, J ) + X( IX )*TEMP
+                     IX = IX + INCX
+   70             CONTINUE
+               END IF
+               JX = JX + INCX
+   80       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZSYR
+*
+      END
diff --git a/SRC/zsyrfs.f b/SRC/zsyrfs.f
new file mode 100644
index 00000000..acfda2c8
--- /dev/null
+++ b/SRC/zsyrfs.f
@@ -0,0 +1,343 @@
+      SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, 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          UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYRFS improves the computed solution to a system of linear
+*  equations when the coefficient matrix is symmetric indefinite, and
+*  provides error bounds and backward error estimates for the solution.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX*16 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(1,N).
+*
+*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)
+*          The factored form of the matrix A.  AF contains the block
+*          diagonal matrix D and the multipliers used to obtain the
+*          factor U or L from the factorization A = U*D*U**T or
+*          A = L*D*L**T as computed by ZSYTRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by ZSYTRF.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by ZSYTRS.
+*          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) 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
+*
+*  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 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZLACN2, ZSYMV, ZSYTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSYRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - A * X
+*
+         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
+         CALL ZSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(A)*abs(X) + abs(B).
+*
+         IF( UPPER ) THEN
+            DO 50 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               DO 40 I = 1, K - 1
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   40          CONTINUE
+               RWORK( K ) = RWORK( K ) + CABS1( A( K, K ) )*XK + S
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               XK = CABS1( X( K, J ) )
+               RWORK( K ) = RWORK( K ) + CABS1( A( K, K ) )*XK
+               DO 60 I = K + 1, N
+                  RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+                  S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+   60          CONTINUE
+               RWORK( K ) = RWORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( 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 ZSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            CALL ZAXPY( N, ONE, WORK, 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(A))*
+*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(A) is the inverse of A
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(A) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(A').
+*
+               CALL ZSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+               DO 110 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  110          CONTINUE
+            ELSE IF( KASE.EQ.2 ) THEN
+*
+*              Multiply by inv(A)*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  120          CONTINUE
+               CALL ZSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK, N, INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of ZSYRFS
+*
+      END
diff --git a/SRC/zsysv.f b/SRC/zsysv.f
new file mode 100644
index 00000000..5b848bfa
--- /dev/null
+++ b/SRC/zsysv.f
@@ -0,0 +1,174 @@
+      SUBROUTINE ZSYSV( 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( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYSV computes the solution to a complex 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) COMPLEX*16 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
+*          ZSYTRF.
+*
+*  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 ZSYTRF.  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) COMPLEX*16 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) COMPLEX*16 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
+*          ZSYTRF.
+*
+*          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           XERBLA, ZSYTRF, ZSYTRS
+*     ..
+*     .. 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, 'ZSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSYSV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZSYSV
+*
+      END
diff --git a/SRC/zsysvx.f b/SRC/zsysvx.f
new file mode 100644
index 00000000..d9cbcd99
--- /dev/null
+++ b/SRC/zsysvx.f
@@ -0,0 +1,300 @@
+      SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+     $                   LDB, X, LDX, RCOND, FERR, BERR, 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          FACT, UPLO
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYSVX uses the diagonal pivoting factorization to compute the
+*  solution to a complex system of linear equations A * X = B,
+*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.
+*     The form of the factorization is
+*        A = U * D * U**T,  if UPLO = 'U', or
+*        A = L * D * L**T,  if UPLO = 'L',
+*     where U (or L) is a product of permutation and unit upper (lower)
+*     triangular matrices, and D is symmetric and block diagonal with
+*     1-by-1 and 2-by-2 diagonal blocks.
+*
+*  2. If some D(i,i)=0, so that D is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  3. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  4. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of A has been
+*          supplied on entry.
+*          = 'F':  On entry, AF and IPIV contain the factored form
+*                  of A.  A, AF and IPIV will not be modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  A       (input) COMPLEX*16 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(1,N).
+*
+*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L from the factorization
+*          A = U*D*U**T or A = L*D*L**T.
+*
+*  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 details of the interchanges and the block structure
+*          of D, as determined by ZSYTRF.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains details of the interchanges and the block structure
+*          of D, as determined by ZSYTRF.
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)
+*          The N-by-NRHS right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+*  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.  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) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= max(1,2*N), and for best
+*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
+*          NB is the optimal blocksize for ZSYTRF.
+*
+*          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
+*          > 0: if INFO = i, and i is
+*                <= N:  D(i,i) is exactly zero.  The factorization
+*                       has been completed but the factor D is exactly
+*                       singular, so the solution and error bounds could
+*                       not be computed. RCOND = 0 is returned.
+*                = N+1: D is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOFACT
+      INTEGER            LWKOPT, NB
+      DOUBLE PRECISION   ANORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANSY
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACPY, ZSYCON, ZSYRFS, ZSYTRF, ZSYTRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -13
+      ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKOPT = MAX( 1, 2*N )
+         IF( NOFACT ) THEN
+            NB = ILAENV( 1, 'ZSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = MAX( LWKOPT, N*NB )
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSYSVX', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      IF( NOFACT ) THEN
+*
+*        Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+         CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+         CALL ZSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 )THEN
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A.
+*
+      ANORM = ZLANSY( 'I', UPLO, N, A, LDA, RWORK )
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL ZSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, INFO )
+*
+*     Compute the solution vectors X.
+*
+      CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL ZSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solutions and
+*     compute error bounds and backward error estimates for them.
+*
+      CALL ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, RWORK, INFO )
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZSYSVX
+*
+      END
diff --git a/SRC/zsytf2.f b/SRC/zsytf2.f
new file mode 100644
index 00000000..7c0a0ce8
--- /dev/null
+++ b/SRC/zsytf2.f
@@ -0,0 +1,522 @@
+      SUBROUTINE ZSYTF2( 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( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYTF2 computes the factorization of a complex 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) COMPLEX*16 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.209 and l.377
+*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*    by
+*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+*  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 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
+      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, ROWMAX
+      COMPLEX*16         D11, D12, D21, D22, R1, T, WK, WKM1, WKP1, Z
+*     ..
+*     .. External Functions ..
+      LOGICAL            DISNAN, LSAME
+      INTEGER            IZAMAX
+      EXTERNAL           DISNAN, LSAME, IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZSCAL, ZSWAP, ZSYR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+*     ..
+*     .. 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( 'ZSYTF2', -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 = CABS1( 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 = IZAMAX( K-1, A( 1, K ), 1 )
+            COLMAX = CABS1( 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 + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+               CALL ZSWAP( 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 = CONE / A( K, K )
+               CALL ZSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+*              Store U(k) in column k
+*
+               CALL ZSCAL( 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 = CONE / ( D11*D22-CONE )
+                  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 = CABS1( 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 + IZAMAX( N-K, A( K+1, K ), 1 )
+            COLMAX = CABS1( 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 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
+               ROWMAX = CABS1( A( IMAX, JMAX ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, CABS1( 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( CABS1( 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 ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+               CALL ZSWAP( 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)'
+*
+                  R1 = CONE / A( K, K )
+                  CALL ZSYR( UPLO, N-K, -R1, A( K+1, K ), 1,
+     $                       A( K+1, K+1 ), LDA )
+*
+*                 Store L(k) in column K
+*
+                  CALL ZSCAL( N-K, R1, 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 - ( 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) )'
+*
+*                 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 = CONE / ( D11*D22-CONE )
+                  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 ZSYTF2
+*
+      END
diff --git a/SRC/zsytrf.f b/SRC/zsytrf.f
new file mode 100644
index 00000000..2c020801
--- /dev/null
+++ b/SRC/zsytrf.f
@@ -0,0 +1,286 @@
+      SUBROUTINE ZSYTRF( 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( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYTRF computes the factorization of a complex 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
+*  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) COMPLEX*16 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) COMPLEX*16 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           XERBLA, ZLASYF, ZSYTF2
+*     ..
+*     .. 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, 'ZSYTRF', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSYTRF', -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, 'ZSYTRF', 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 ZLASYF;
+*        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 ZLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns 1:k of A
+*
+            CALL ZSYTF2( 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 ZLASYF;
+*        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 ZLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+     $                   WORK, N, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns k:n of A
+*
+            CALL ZSYTF2( 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 ZSYTRF
+*
+      END
diff --git a/SRC/zsytri.f b/SRC/zsytri.f
new file mode 100644
index 00000000..813b41d2
--- /dev/null
+++ b/SRC/zsytri.f
@@ -0,0 +1,313 @@
+      SUBROUTINE ZSYTRI( 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( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYTRI computes the inverse of a complex symmetric indefinite matrix
+*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by
+*  ZSYTRF.
+*
+*  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) COMPLEX*16 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 ZSYTRF.
+*
+*          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 ZSYTRF.
+*
+*  WORK    (workspace) COMPLEX*16 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, D(i,i) = 0; the matrix is singular and its
+*               inverse could 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            UPPER
+      INTEGER            K, KP, KSTEP
+      COMPLEX*16         AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTU
+      EXTERNAL           LSAME, ZDOTU
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZSWAP, ZSYMV
+*     ..
+*     .. 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( 'ZSYTRI', -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 ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = 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 ZCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - ZDOTU( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+               A( K, K+1 ) = A( K, K+1 ) -
+     $                       ZDOTU( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+               CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+               CALL ZSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K+1 ), 1 )
+               A( K+1, K+1 ) = A( K+1, K+1 ) -
+     $                         ZDOTU( 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 ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+            CALL ZSWAP( 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 ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = 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 ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL ZSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - ZDOTU( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+               A( K, K-1 ) = A( K, K-1 ) -
+     $                       ZDOTU( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+     $                       1 )
+               CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+               CALL ZSYMV( 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 ) -
+     $                         ZDOTU( 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 ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+            CALL ZSWAP( 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 ZSYTRI
+*
+      END
diff --git a/SRC/zsytrs.f b/SRC/zsytrs.f
new file mode 100644
index 00000000..3b2bbb46
--- /dev/null
+++ b/SRC/zsytrs.f
@@ -0,0 +1,369 @@
+      SUBROUTINE ZSYTRS( 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( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSYTRS solves a system of linear equations A*X = B with a complex
+*  symmetric matrix A using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by ZSYTRF.
+*
+*  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) COMPLEX*16 array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by ZSYTRF.
+*
+*  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 ZSYTRF.
+*
+*  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            UPPER
+      INTEGER            J, K, KP
+      COMPLEX*16         AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP
+*     ..
+*     .. 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( 'ZSYTRS', -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 ZSWAP( 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 ZGERU( 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 ZSCAL( 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 ZSWAP( 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 ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                  B( 1, 1 ), LDB )
+            CALL ZGERU( 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 ZGEMV( '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 ZSWAP( 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 ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL ZGEMV( '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 ZSWAP( 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 ZSWAP( 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 ZGERU( 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 ZSCAL( 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 ZSWAP( 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 ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+     $                     LDB, B( K+2, 1 ), LDB )
+               CALL ZGERU( 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 ZGEMV( '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 ZSWAP( 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 ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL ZGEMV( '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 ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZSYTRS
+*
+      END
diff --git a/SRC/ztbcon.f b/SRC/ztbcon.f
new file mode 100644
index 00000000..2d94db4a
--- /dev/null
+++ b/SRC/ztbcon.f
@@ -0,0 +1,209 @@
+      SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, 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          DIAG, NORM, UPLO
+      INTEGER            INFO, KD, LDAB, N
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTBCON estimates the reciprocal of the condition number of a
+*  triangular band matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  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 (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
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH, ZLANTB
+      EXTERNAL           LSAME, IZAMAX, DLAMCH, ZLANTB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDRSCL, ZLACN2, ZLATBS
+*     ..
+*     .. 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
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTBCON', -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( N, 1 ) )
+*
+*     Compute the 1-norm of the triangular matrix A or A'.
+*
+      ANORM = ZLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, RWORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the 1-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 ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL ZLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
+     $                      AB, LDAB, WORK, SCALE, RWORK, INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL ZLATBS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
+     $                      N, KD, AB, LDAB, WORK, SCALE, RWORK, INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = IZAMAX( N, WORK, 1 )
+               XNORM = CABS1( WORK( IX ) )
+               IF( SCALE.LT.XNORM*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 / ANORM ) / AINVNM
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of ZTBCON
+*
+      END
diff --git a/SRC/ztbrfs.f b/SRC/ztbrfs.f
new file mode 100644
index 00000000..91d73483
--- /dev/null
+++ b/SRC/ztbrfs.f
@@ -0,0 +1,397 @@
+      SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
+     $                   LDB, X, LDX, FERR, BERR, 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          DIAG, TRANS, UPLO
+      INTEGER            INFO, KD, LDAB, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AB( LDAB, * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTBRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular band
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by ZTBTRS or some other
+*  means before entering this routine.  ZTBRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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)
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of the array. The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          The 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) 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANSN, TRANST
+      INTEGER            I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZLACN2, ZTBMV, ZTBSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTBRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = KD + 2
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL ZCOPY( N, X( 1, J ), 1, WORK, 1 )
+         CALL ZTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
+         CALL ZAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 30 I = MAX( 1, K-KD ), K
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( KD+1+I-K, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 50 I = MAX( 1, K-KD ), K - 1
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( KD+1+I-K, K ) )*XK
+   50                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 70 I = K, MIN( N, K+KD )
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( 1+I-K, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 90 I = K + 1, MIN( N, K+KD )
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AB( 1+I-K, K ) )*XK
+   90                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A**H)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = MAX( 1, K-KD ), K
+                        S = S + CABS1( AB( KD+1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  110                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 130 I = MAX( 1, K-KD ), K - 1
+                        S = S + CABS1( AB( KD+1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  130                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, MIN( N, K+KD )
+                        S = S + CABS1( AB( 1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  150                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 170 I = K + 1, MIN( N, K+KD )
+                        S = S + CABS1( AB( 1+I-K, K ) )*
+     $                      CABS1( X( I, J ) )
+  170                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL ZTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB, WORK,
+     $                     1 )
+               DO 220 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  230          CONTINUE
+               CALL ZTBSV( UPLO, TRANSN, DIAG, N, KD, AB, LDAB, WORK,
+     $                     1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of ZTBRFS
+*
+      END
diff --git a/SRC/ztbtrs.f b/SRC/ztbtrs.f
new file mode 100644
index 00000000..7e9ab0bc
--- /dev/null
+++ b/SRC/ztbtrs.f
@@ -0,0 +1,162 @@
+      SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, 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, KD, LDAB, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AB( LDAB, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTBTRS solves a triangular system of the form
+*
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*
+*  where A is a triangular band matrix of order N, and B is an
+*  N-by-NRHS matrix.  A check is made to verify that A is nonsingular.
+*
+*  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)
+*
+*  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.
+*
+*  KD      (input) INTEGER
+*          The number of superdiagonals or subdiagonals of the
+*          triangular band matrix A.  KD >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
+*          The upper or lower triangular band matrix A, stored in the
+*          first kd+1 rows of AB.  The j-th column of A is stored
+*          in the j-th column of the array AB as follows:
+*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  LDAB    (input) INTEGER
+*          The leading dimension of the array AB.  LDAB >= KD+1.
+*
+*  B       (input/output) COMPLEX*16 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 ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTBSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOUNIT = LSAME( DIAG, 'N' )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( KD.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDAB.LT.KD+1 ) THEN
+         INFO = -8
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTBTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            DO 10 INFO = 1, N
+               IF( AB( KD+1, INFO ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            DO 20 INFO = 1, N
+               IF( AB( 1, INFO ).EQ.ZERO )
+     $            RETURN
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve A * X = B,  A**T * X = B,  or  A**H * X = B.
+*
+      DO 30 J = 1, NRHS
+         CALL ZTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of ZTBTRS
+*
+      END
diff --git a/SRC/ztgevc.f b/SRC/ztgevc.f
new file mode 100644
index 00000000..b8da962d
--- /dev/null
+++ b/SRC/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/ztgex2.f b/SRC/ztgex2.f
new file mode 100644
index 00000000..a0c42aad
--- /dev/null
+++ b/SRC/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/ztgexc.f b/SRC/ztgexc.f
new file mode 100644
index 00000000..0f57939c
--- /dev/null
+++ b/SRC/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/ztgsen.f b/SRC/ztgsen.f
new file mode 100644
index 00000000..4c5acaff
--- /dev/null
+++ b/SRC/ztgsen.f
@@ -0,0 +1,653 @@
+      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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     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
+      COMPLEX*16         TEMP1, TEMP2
+*     ..
+*     .. 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
+            TEMP1 = DCONJG( B( K, K ) / DSCALE )
+            TEMP2 = B( K, K ) / DSCALE
+            B( K, K ) = DSCALE
+            CALL ZSCAL( N-K, TEMP1, B( K, K+1 ), LDB )
+            CALL ZSCAL( N-K+1, TEMP1, A( K, K ), LDA )
+            IF( WANTQ )
+     $         CALL ZSCAL( N, TEMP2, 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/ztgsja.f b/SRC/ztgsja.f
new file mode 100644
index 00000000..05653757
--- /dev/null
+++ b/SRC/ztgsja.f
@@ -0,0 +1,525 @@
+      SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
+     $                   LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV,
+     $                   Q, LDQ, WORK, NCYCLE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBQ, JOBU, JOBV
+      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
+     $                   NCYCLE, P
+      DOUBLE PRECISION   TOLA, TOLB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   ALPHA( * ), BETA( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   U( LDU, * ), V( LDV, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGSJA computes the generalized singular value decomposition (GSVD)
+*  of two complex upper triangular (or trapezoidal) matrices A and B.
+*
+*  On entry, it is assumed that matrices A and B have the following
+*  forms, which may be obtained by the preprocessing subroutine ZGGSVP
+*  from a general M-by-N matrix A and P-by-N matrix B:
+*
+*               N-K-L  K    L
+*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;
+*            L ( 0     0   A23 )
+*        M-K-L ( 0     0    0  )
+*
+*             N-K-L  K    L
+*     A =  K ( 0    A12  A13 ) if M-K-L < 0;
+*        M-K ( 0     0   A23 )
+*
+*             N-K-L  K    L
+*     B =  L ( 0     0   B13 )
+*        P-L ( 0     0    0  )
+*
+*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+*  otherwise A23 is (M-K)-by-L upper trapezoidal.
+*
+*  On exit,
+*
+*         U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),
+*
+*  where U, V and Q are unitary matrices, Z' denotes the conjugate
+*  transpose of Z, R is a nonsingular upper triangular matrix, and D1
+*  and D2 are ``diagonal'' matrices, which are of the following
+*  structures:
+*
+*  If M-K-L >= 0,
+*
+*                      K  L
+*         D1 =     K ( I  0 )
+*                  L ( 0  C )
+*              M-K-L ( 0  0 )
+*
+*                     K  L
+*         D2 = L   ( 0  S )
+*              P-L ( 0  0 )
+*
+*                 N-K-L  K    L
+*    ( 0 R ) = K (  0   R11  R12 ) K
+*              L (  0    0   R22 ) L
+*
+*  where
+*
+*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+*    S = diag( BETA(K+1),  ... , BETA(K+L) ),
+*    C**2 + S**2 = I.
+*
+*    R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+*  If M-K-L < 0,
+*
+*                 K M-K K+L-M
+*      D1 =   K ( I  0    0   )
+*           M-K ( 0  C    0   )
+*
+*                   K M-K K+L-M
+*      D2 =   M-K ( 0  S    0   )
+*           K+L-M ( 0  0    I   )
+*             P-L ( 0  0    0   )
+*
+*                 N-K-L  K   M-K  K+L-M
+* ( 0 R ) =    K ( 0    R11  R12  R13  )
+*            M-K ( 0     0   R22  R23  )
+*          K+L-M ( 0     0    0   R33  )
+*
+*  where
+*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+*  S = diag( BETA(K+1),  ... , BETA(M) ),
+*  C**2 + S**2 = I.
+*
+*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
+*      (  0  R22 R23 )
+*  in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+*  The computation of the unitary transformation matrices U, V or Q
+*  is optional.  These matrices may either be formed explicitly, or they
+*  may be postmultiplied into input matrices U1, V1, or Q1.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          = 'U':  U must contain a unitary matrix U1 on entry, and
+*                  the product U1*U is returned;
+*          = 'I':  U is initialized to the unit matrix, and the
+*                  unitary matrix U is returned;
+*          = 'N':  U is not computed.
+*
+*  JOBV    (input) CHARACTER*1
+*          = 'V':  V must contain a unitary matrix V1 on entry, and
+*                  the product V1*V is returned;
+*          = 'I':  V is initialized to the unit matrix, and the
+*                  unitary matrix V is returned;
+*          = 'N':  V is not computed.
+*
+*  JOBQ    (input) CHARACTER*1
+*          = 'Q':  Q must contain a unitary matrix Q1 on entry, and
+*                  the product Q1*Q is returned;
+*          = 'I':  Q is initialized to the unit matrix, and the
+*                  unitary matrix Q is returned;
+*          = 'N':  Q is not computed.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  P       (input) INTEGER
+*          The number of rows of the matrix B.  P >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrices A and B.  N >= 0.
+*
+*  K       (input) INTEGER
+*  L       (input) INTEGER
+*          K and L specify the subblocks in the input matrices A and B:
+*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)
+*          of A and B, whose GSVD is going to be computed by ZTGSJA.
+*          See Further details.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
+*          matrix R or part of R.  See Purpose for details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the P-by-N matrix B.
+*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
+*          a part of R.  See Purpose for details.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,P).
+*
+*  TOLA    (input) DOUBLE PRECISION
+*  TOLB    (input) DOUBLE PRECISION
+*          TOLA and TOLB are the convergence criteria for the Jacobi-
+*          Kogbetliantz iteration procedure. Generally, they are the
+*          same as used in the preprocessing step, say
+*              TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+*              TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+*
+*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, ALPHA and BETA contain the generalized singular
+*          value pairs of A and B;
+*            ALPHA(1:K) = 1,
+*            BETA(1:K)  = 0,
+*          and if M-K-L >= 0,
+*            ALPHA(K+1:K+L) = diag(C),
+*            BETA(K+1:K+L)  = diag(S),
+*          or if M-K-L < 0,
+*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
+*          Furthermore, if K+L < N,
+*            ALPHA(K+L+1:N) = 0
+*            BETA(K+L+1:N)  = 0.
+*
+*  U       (input/output) COMPLEX*16 array, dimension (LDU,M)
+*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
+*          the unitary matrix returned by ZGGSVP).
+*          On exit,
+*          if JOBU = 'I', U contains the unitary matrix U;
+*          if JOBU = 'U', U contains the product U1*U.
+*          If JOBU = 'N', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U. LDU >= max(1,M) if
+*          JOBU = 'U'; LDU >= 1 otherwise.
+*
+*  V       (input/output) COMPLEX*16 array, dimension (LDV,P)
+*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
+*          the unitary matrix returned by ZGGSVP).
+*          On exit,
+*          if JOBV = 'I', V contains the unitary matrix V;
+*          if JOBV = 'V', V contains the product V1*V.
+*          If JOBV = 'N', V is not referenced.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,P) if
+*          JOBV = 'V'; LDV >= 1 otherwise.
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
+*          the unitary matrix returned by ZGGSVP).
+*          On exit,
+*          if JOBQ = 'I', Q contains the unitary matrix Q;
+*          if JOBQ = 'Q', Q contains the product Q1*Q.
+*          If JOBQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N) if
+*          JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
+*
+*  NCYCLE  (output) INTEGER
+*          The number of cycles required for convergence.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1:  the procedure does not converge after MAXIT cycles.
+*
+*  Internal Parameters
+*  ===================
+*
+*  MAXIT   INTEGER
+*          MAXIT specifies the total loops that the iterative procedure
+*          may take. If after MAXIT cycles, the routine fails to
+*          converge, we return INFO = 1.
+*
+*  Further Details
+*  ===============
+*
+*  ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
+*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
+*  matrix B13 to the form:
+*
+*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
+*
+*  where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate
+*  transpose of Z.  C1 and S1 are diagonal matrices satisfying
+*
+*                C1**2 + S1**2 = I,
+*
+*  and R1 is an L-by-L nonsingular upper triangular matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 40 )
+      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            INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
+      INTEGER            I, J, KCYCLE
+      DOUBLE PRECISION   A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
+     $                   RWK, SSMIN
+      COMPLEX*16         A2, B2, SNQ, SNU, SNV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARTG, XERBLA, ZCOPY, ZDSCAL, ZLAGS2, ZLAPLL,
+     $                   ZLASET, ZROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      INITU = LSAME( JOBU, 'I' )
+      WANTU = INITU .OR. LSAME( JOBU, 'U' )
+*
+      INITV = LSAME( JOBV, 'I' )
+      WANTV = INITV .OR. LSAME( JOBV, 'V' )
+*
+      INITQ = LSAME( JOBQ, 'I' )
+      WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
+*
+      INFO = 0
+      IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( P.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+         INFO = -12
+      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+         INFO = -18
+      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+         INFO = -20
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -22
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGSJA', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize U, V and Q, if necessary
+*
+      IF( INITU )
+     $   CALL ZLASET( 'Full', M, M, CZERO, CONE, U, LDU )
+      IF( INITV )
+     $   CALL ZLASET( 'Full', P, P, CZERO, CONE, V, LDV )
+      IF( INITQ )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+*
+*     Loop until convergence
+*
+      UPPER = .FALSE.
+      DO 40 KCYCLE = 1, MAXIT
+*
+         UPPER = .NOT.UPPER
+*
+         DO 20 I = 1, L - 1
+            DO 10 J = I + 1, L
+*
+               A1 = ZERO
+               A2 = CZERO
+               A3 = ZERO
+               IF( K+I.LE.M )
+     $            A1 = DBLE( A( K+I, N-L+I ) )
+               IF( K+J.LE.M )
+     $            A3 = DBLE( A( K+J, N-L+J ) )
+*
+               B1 = DBLE( B( I, N-L+I ) )
+               B3 = DBLE( B( J, N-L+J ) )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A2 = A( K+I, N-L+J )
+                  B2 = B( I, N-L+J )
+               ELSE
+                  IF( K+J.LE.M )
+     $               A2 = A( K+J, N-L+I )
+                  B2 = B( J, N-L+I )
+               END IF
+*
+               CALL ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
+     $                      CSV, SNV, CSQ, SNQ )
+*
+*              Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
+*
+               IF( K+J.LE.M )
+     $            CALL ZROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
+     $                       LDA, CSU, DCONJG( SNU ) )
+*
+*              Update I-th and J-th rows of matrix B: V'*B
+*
+               CALL ZROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
+     $                    CSV, DCONJG( SNV ) )
+*
+*              Update (N-L+I)-th and (N-L+J)-th columns of matrices
+*              A and B: A*Q and B*Q
+*
+               CALL ZROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
+     $                    A( 1, N-L+I ), 1, CSQ, SNQ )
+*
+               CALL ZROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
+     $                    SNQ )
+*
+               IF( UPPER ) THEN
+                  IF( K+I.LE.M )
+     $               A( K+I, N-L+J ) = CZERO
+                  B( I, N-L+J ) = CZERO
+               ELSE
+                  IF( K+J.LE.M )
+     $               A( K+J, N-L+I ) = CZERO
+                  B( J, N-L+I ) = CZERO
+               END IF
+*
+*              Ensure that the diagonal elements of A and B are real.
+*
+               IF( K+I.LE.M )
+     $            A( K+I, N-L+I ) = DBLE( A( K+I, N-L+I ) )
+               IF( K+J.LE.M )
+     $            A( K+J, N-L+J ) = DBLE( A( K+J, N-L+J ) )
+               B( I, N-L+I ) = DBLE( B( I, N-L+I ) )
+               B( J, N-L+J ) = DBLE( B( J, N-L+J ) )
+*
+*              Update unitary matrices U, V, Q, if desired.
+*
+               IF( WANTU .AND. K+J.LE.M )
+     $            CALL ZROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
+     $                       SNU )
+*
+               IF( WANTV )
+     $            CALL ZROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
+*
+               IF( WANTQ )
+     $            CALL ZROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
+     $                       SNQ )
+*
+   10       CONTINUE
+   20    CONTINUE
+*
+         IF( .NOT.UPPER ) THEN
+*
+*           The matrices A13 and B13 were lower triangular at the start
+*           of the cycle, and are now upper triangular.
+*
+*           Convergence test: test the parallelism of the corresponding
+*           rows of A and B.
+*
+            ERROR = ZERO
+            DO 30 I = 1, MIN( L, M-K )
+               CALL ZCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
+               CALL ZCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
+               CALL ZLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
+               ERROR = MAX( ERROR, SSMIN )
+   30       CONTINUE
+*
+            IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
+     $         GO TO 50
+         END IF
+*
+*        End of cycle loop
+*
+   40 CONTINUE
+*
+*     The algorithm has not converged after MAXIT cycles.
+*
+      INFO = 1
+      GO TO 100
+*
+   50 CONTINUE
+*
+*     If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
+*     Compute the generalized singular value pairs (ALPHA, BETA), and
+*     set the triangular matrix R to array A.
+*
+      DO 60 I = 1, K
+         ALPHA( I ) = ONE
+         BETA( I ) = ZERO
+   60 CONTINUE
+*
+      DO 70 I = 1, MIN( L, M-K )
+*
+         A1 = DBLE( A( K+I, N-L+I ) )
+         B1 = DBLE( B( I, N-L+I ) )
+*
+         IF( A1.NE.ZERO ) THEN
+            GAMMA = B1 / A1
+*
+            IF( GAMMA.LT.ZERO ) THEN
+               CALL ZDSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
+               IF( WANTV )
+     $            CALL ZDSCAL( P, -ONE, V( 1, I ), 1 )
+            END IF
+*
+            CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
+     $                   RWK )
+*
+            IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
+               CALL ZDSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
+     $                      LDA )
+            ELSE
+               CALL ZDSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
+     $                      LDB )
+               CALL ZCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                     LDA )
+            END IF
+*
+         ELSE
+            ALPHA( K+I ) = ZERO
+            BETA( K+I ) = ONE
+            CALL ZCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+     $                  LDA )
+         END IF
+   70 CONTINUE
+*
+*     Post-assignment
+*
+      DO 80 I = M + 1, K + L
+         ALPHA( I ) = ZERO
+         BETA( I ) = ONE
+   80 CONTINUE
+*
+      IF( K+L.LT.N ) THEN
+         DO 90 I = K + L + 1, N
+            ALPHA( I ) = ZERO
+            BETA( I ) = ZERO
+   90    CONTINUE
+      END IF
+*
+  100 CONTINUE
+      NCYCLE = KCYCLE
+*
+      RETURN
+*
+*     End of ZTGSJA
+*
+      END
diff --git a/SRC/ztgsna.f b/SRC/ztgsna.f
new file mode 100644
index 00000000..3d6cd826
--- /dev/null
+++ b/SRC/ztgsna.f
@@ -0,0 +1,397 @@
+      SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
+     $                   LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, JOB
+      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   DIF( * ), S( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or eigenvectors of a matrix pair (A, B).
+*
+*  (A, B) must be in generalized Schur canonical form, that is, A and
+*  B are both upper triangular.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (DIF):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (DIF);
+*          = 'B': for both eigenvalues and eigenvectors (S and DIF).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the corresponding j-th eigenvalue and/or eigenvector,
+*          SELECT(j) must be set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the square matrix pair (A, B). N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The upper triangular matrix A in the pair (A,B).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,N)
+*          The upper triangular matrix B in the pair (A, B).
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  VL      (input) COMPLEX*16 array, dimension (LDVL,M)
+*          IF JOB = 'E' or 'B', VL must contain left eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT.  The eigenvectors must be stored in consecutive
+*          columns of VL, as returned by ZTGEVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL. LDVL >= 1; and
+*          If JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) COMPLEX*16 array, dimension (LDVR,M)
+*          IF JOB = 'E' or 'B', VR must contain right eigenvectors of
+*          (A, B), corresponding to the eigenpairs specified by HOWMNY
+*          and SELECT.  The eigenvectors must be stored in consecutive
+*          columns of VR, as returned by ZTGEVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR. LDVR >= 1;
+*          If JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array.
+*          If JOB = 'V', S is not referenced.
+*
+*  DIF     (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array.
+*          If the eigenvalues cannot be reordered to compute DIF(j),
+*          DIF(j) is set to 0; this can only occur when the true value
+*          would be very small anyway.
+*          For each eigenvalue/vector specified by SELECT, DIF stores
+*          a Frobenius norm-based estimate of Difl.
+*          If JOB = 'E', DIF is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S and DIF. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and DIF used to store
+*          the specified condition numbers; for each selected eigenvalue
+*          one element is used. If HOWMNY = 'A', M is set to 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 JOB = 'V' or 'B', LWORK >= max(1,2*N*N).
+*
+*  IWORK   (workspace) INTEGER array, dimension (N+2)
+*          If JOB = 'E', IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0: Successful exit
+*          < 0: If INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of the i-th generalized
+*  eigenvalue w = (a, b) is defined as
+*
+*          S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))
+*
+*  where u and v are the right and left eigenvectors of (A, B)
+*  corresponding to w; |z| denotes the absolute value of the complex
+*  number, and norm(u) denotes the 2-norm of the vector u. The pair
+*  (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the
+*  matrix pair (A, B). If both a and b equal zero, then (A,B) is
+*  singular and S(I) = -1 is returned.
+*
+*  An approximate error bound on the chordal distance between the i-th
+*  computed generalized eigenvalue w and the corresponding exact
+*  eigenvalue lambda is
+*
+*          chord(w, lambda) <=   EPS * norm(A, B) / S(I),
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number of the right eigenvector u
+*  and left eigenvector v corresponding to the generalized eigenvalue w
+*  is defined as follows. Suppose
+*
+*                   (A, B) = ( a   *  ) ( b  *  )  1
+*                            ( 0  A22 ),( 0 B22 )  n-1
+*                              1  n-1     1 n-1
+*
+*  Then the reciprocal condition number DIF(I) is
+*
+*          Difl[(a, b), (A22, B22)]  = sigma-min( Zl )
+*
+*  where sigma-min(Zl) denotes the smallest singular value of
+*
+*         Zl = [ kron(a, In-1) -kron(1, A22) ]
+*              [ kron(b, In-1) -kron(1, B22) ].
+*
+*  Here In-1 is the identity matrix of size n-1 and X' is the conjugate
+*  transpose of X. kron(X, Y) is the Kronecker product between the
+*  matrices X and Y.
+*
+*  We approximate the smallest singular value of Zl with an upper
+*  bound. This is done by ZLATDF.
+*
+*  An approximate error bound for a computed eigenvector VL(i) or
+*  VR(i) is given by
+*
+*                      EPS * norm(A, B) / DIF(i).
+*
+*  See ref. [2-3] for more details and further references.
+*
+*  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 ..
+      DOUBLE PRECISION   ZERO, ONE
+      INTEGER            IDIFJB
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, IDIFJB = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SOMCON, WANTBH, WANTDF, WANTS
+      INTEGER            I, IERR, IFST, ILST, K, KS, LWMIN, N1, N2
+      DOUBLE PRECISION   BIGNUM, COND, EPS, LNRM, RNRM, SCALE, SMLNUM
+      COMPLEX*16         YHAX, YHBX
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         DUMMY( 1 ), DUMMY1( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLAPY2, DZNRM2
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, DLAMCH, DLAPY2, DZNRM2, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZGEMV, ZLACPY, ZTGEXC, ZTGSYL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCMPLX, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
+         INFO = -10
+      ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
+         INFO = -12
+      ELSE
+*
+*        Set M to the number of eigenpairs for which condition numbers
+*        are required, and test MM.
+*
+         IF( SOMCON ) THEN
+            M = 0
+            DO 10 K = 1, N
+               IF( SELECT( K ) )
+     $            M = M + 1
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( N.EQ.0 ) THEN
+            LWMIN = 1
+         ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
+            LWMIN = 2*N*N
+         ELSE
+            LWMIN = N
+         END IF
+         WORK( 1 ) = LWMIN
+*
+         IF( MM.LT.M ) THEN
+            INFO = -15
+         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGSNA', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      KS = 0
+      DO 20 K = 1, N
+*
+*        Determine whether condition numbers are required for the k-th
+*        eigenpair.
+*
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( K ) )
+     $         GO TO 20
+         END IF
+*
+         KS = KS + 1
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            RNRM = DZNRM2( N, VR( 1, KS ), 1 )
+            LNRM = DZNRM2( N, VL( 1, KS ), 1 )
+            CALL ZGEMV( 'N', N, N, DCMPLX( ONE, ZERO ), A, LDA,
+     $                  VR( 1, KS ), 1, DCMPLX( ZERO, ZERO ), WORK, 1 )
+            YHAX = ZDOTC( N, WORK, 1, VL( 1, KS ), 1 )
+            CALL ZGEMV( 'N', N, N, DCMPLX( ONE, ZERO ), B, LDB,
+     $                  VR( 1, KS ), 1, DCMPLX( ZERO, ZERO ), WORK, 1 )
+            YHBX = ZDOTC( N, WORK, 1, VL( 1, KS ), 1 )
+            COND = DLAPY2( ABS( YHAX ), ABS( YHBX ) )
+            IF( COND.EQ.ZERO ) THEN
+               S( KS ) = -ONE
+            ELSE
+               S( KS ) = COND / ( RNRM*LNRM )
+            END IF
+         END IF
+*
+         IF( WANTDF ) THEN
+            IF( N.EQ.1 ) THEN
+               DIF( KS ) = DLAPY2( ABS( A( 1, 1 ) ), ABS( B( 1, 1 ) ) )
+            ELSE
+*
+*              Estimate the reciprocal condition number of the k-th
+*              eigenvectors.
+*
+*              Copy the matrix (A, B) to the array WORK and move the
+*              (k,k)th pair to the (1,1) position.
+*
+               CALL ZLACPY( 'Full', N, N, A, LDA, WORK, N )
+               CALL ZLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+               IFST = K
+               ILST = 1
+*
+               CALL ZTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ),
+     $                      N, DUMMY, 1, DUMMY1, 1, IFST, ILST, IERR )
+*
+               IF( IERR.GT.0 ) THEN
+*
+*                 Ill-conditioned problem - swap rejected.
+*
+                  DIF( KS ) = ZERO
+               ELSE
+*
+*                 Reordering successful, solve generalized Sylvester
+*                 equation for R and L,
+*                            A22 * R - L * A11 = A12
+*                            B22 * R - L * B11 = B12,
+*                 and compute estimate of Difl[(A11,B11), (A22, B22)].
+*
+                  N1 = 1
+                  N2 = N - N1
+                  I = N*N + 1
+                  CALL ZTGSYL( 'N', IDIFJB, N2, N1, WORK( N*N1+N1+1 ),
+     $                         N, WORK, N, WORK( N1+1 ), N,
+     $                         WORK( N*N1+N1+I ), N, WORK( I ), N,
+     $                         WORK( N1+I ), N, SCALE, DIF( KS ), DUMMY,
+     $                         1, IWORK, IERR )
+               END IF
+            END IF
+         END IF
+*
+   20 CONTINUE
+      WORK( 1 ) = LWMIN
+      RETURN
+*
+*     End of ZTGSNA
+*
+      END
diff --git a/SRC/ztgsy2.f b/SRC/ztgsy2.f
new file mode 100644
index 00000000..82ec5eb1
--- /dev/null
+++ b/SRC/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/ztgsyl.f b/SRC/ztgsyl.f
new file mode 100644
index 00000000..7be8e987
--- /dev/null
+++ b/SRC/ztgsyl.f
@@ -0,0 +1,574 @@
+      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.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. 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)
+*
+*  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/ztpcon.f b/SRC/ztpcon.f
new file mode 100644
index 00000000..63d1f88f
--- /dev/null
+++ b/SRC/ztpcon.f
@@ -0,0 +1,198 @@
+      SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, 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          DIAG, NORM, UPLO
+      INTEGER            INFO, N
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTPCON estimates the reciprocal of the condition number of a packed
+*  triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  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 (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
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH, ZLANTP
+      EXTERNAL           LSAME, IZAMAX, DLAMCH, ZLANTP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDRSCL, ZLACN2, ZLATPS
+*     ..
+*     .. 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
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTPCON', -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 = ZLANTP( NORM, UPLO, DIAG, N, AP, RWORK )
+*
+*     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 ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL ZLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
+     $                      WORK, SCALE, RWORK, INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL ZLATPS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
+     $                      N, AP, WORK, SCALE, RWORK, INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = IZAMAX( N, WORK, 1 )
+               XNORM = CABS1( WORK( IX ) )
+               IF( SCALE.LT.XNORM*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 / ANORM ) / AINVNM
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of ZTPCON
+*
+      END
diff --git a/SRC/ztprfs.f b/SRC/ztprfs.f
new file mode 100644
index 00000000..081b452c
--- /dev/null
+++ b/SRC/ztprfs.f
@@ -0,0 +1,391 @@
+      SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
+     $                   FERR, BERR, 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          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTPRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular packed
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by ZTPTRS or some other
+*  means before entering this routine.  ZTPRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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)
+*
+*  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 matrices B and X.  NRHS >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          If DIAG = 'U', the diagonal elements of A are not referenced
+*          and are assumed to be 1.
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          The 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) 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANSN, TRANST
+      INTEGER            I, J, K, KASE, KC, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZLACN2, ZTPMV, ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTPRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL ZCOPY( N, X( 1, J ), 1, WORK, 1 )
+         CALL ZTPMV( UPLO, TRANS, DIAG, N, AP, WORK, 1 )
+         CALL ZAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 30 I = 1, K
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-1 ) )*XK
+   30                CONTINUE
+                     KC = KC + K
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-1 ) )*XK
+   50                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+                     KC = KC + K
+   60             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 70 I = K, N
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-K ) )*XK
+   70                CONTINUE
+                     KC = KC + N - K + 1
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        RWORK( I ) = RWORK( I ) +
+     $                               CABS1( AP( KC+I-K ) )*XK
+   90                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+                     KC = KC + N - K + 1
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A**H)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + CABS1( AP( KC+I-1 ) )*CABS1( X( I, J ) )
+  110                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + K
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + CABS1( AP( KC+I-1 ) )*CABS1( X( I, J ) )
+  130                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + K
+  140             CONTINUE
+               END IF
+            ELSE
+               KC = 1
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + CABS1( AP( KC+I-K ) )*CABS1( X( I, J ) )
+  150                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + N - K + 1
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + CABS1( AP( KC+I-K ) )*CABS1( X( I, J ) )
+  170                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+                     KC = KC + N - K + 1
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL ZTPSV( UPLO, TRANST, DIAG, N, AP, WORK, 1 )
+               DO 220 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  230          CONTINUE
+               CALL ZTPSV( UPLO, TRANSN, DIAG, N, AP, WORK, 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of ZTPRFS
+*
+      END
diff --git a/SRC/ztptri.f b/SRC/ztptri.f
new file mode 100644
index 00000000..8fa22865
--- /dev/null
+++ b/SRC/ztptri.f
@@ -0,0 +1,176 @@
+      SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, 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, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTPTRI computes the inverse of a complex upper or lower triangular
+*  matrix A stored in packed format.
+*
+*  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.
+*
+*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangular matrix A, stored
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same packed storage format.
+*
+*  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.
+*
+*  Further Details
+*  ===============
+*
+*  A triangular matrix A can be transferred to packed storage using one
+*  of the following program segments:
+*
+*  UPLO = 'U':                      UPLO = 'L':
+*
+*        JC = 1                           JC = 1
+*        DO 2 J = 1, N                    DO 2 J = 1, N
+*           DO 1 I = 1, J                    DO 1 I = J, N
+*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
+*      1    CONTINUE                    1    CONTINUE
+*           JC = JC + J                      JC = JC + N - J + 1
+*      2 CONTINUE                       2 CONTINUE
+*
+*  =====================================================================
+*
+*     .. 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, JC, JCLAST, JJ
+      COMPLEX*16         AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZSCAL, ZTPMV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTPTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Check for singularity if non-unit.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JJ = 0
+            DO 10 INFO = 1, N
+               JJ = JJ + INFO
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+   10       CONTINUE
+         ELSE
+            JJ = 1
+            DO 20 INFO = 1, N
+               IF( AP( JJ ).EQ.ZERO )
+     $            RETURN
+               JJ = JJ + N - INFO + 1
+   20       CONTINUE
+         END IF
+         INFO = 0
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Compute inverse of upper triangular matrix.
+*
+         JC = 1
+         DO 30 J = 1, N
+            IF( NOUNIT ) THEN
+               AP( JC+J-1 ) = ONE / AP( JC+J-1 )
+               AJJ = -AP( JC+J-1 )
+            ELSE
+               AJJ = -ONE
+            END IF
+*
+*           Compute elements 1:j-1 of j-th column.
+*
+            CALL ZTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
+     $                  AP( JC ), 1 )
+            CALL ZSCAL( J-1, AJJ, AP( JC ), 1 )
+            JC = JC + J
+   30    CONTINUE
+*
+      ELSE
+*
+*        Compute inverse of lower triangular matrix.
+*
+         JC = N*( N+1 ) / 2
+         DO 40 J = N, 1, -1
+            IF( NOUNIT ) THEN
+               AP( JC ) = ONE / AP( JC )
+               AJJ = -AP( JC )
+            ELSE
+               AJJ = -ONE
+            END IF
+            IF( J.LT.N ) THEN
+*
+*              Compute elements j+1:n of j-th column.
+*
+               CALL ZTPMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     AP( JCLAST ), AP( JC+1 ), 1 )
+               CALL ZSCAL( N-J, AJJ, AP( JC+1 ), 1 )
+            END IF
+            JCLAST = JC
+            JC = JC - N + J - 2
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZTPTRI
+*
+      END
diff --git a/SRC/ztptrs.f b/SRC/ztptrs.f
new file mode 100644
index 00000000..c50503e3
--- /dev/null
+++ b/SRC/ztptrs.f
@@ -0,0 +1,153 @@
+      SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, 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, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTPTRS solves a triangular system of the form
+*
+*     A * X = B,  A**T * X = B,  or  A**H * X = B,
+*
+*  where A is a triangular matrix of order N stored in packed format,
+*  and B is an N-by-NRHS matrix.  A check is made to verify that A is
+*  nonsingular.
+*
+*  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)
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The upper or lower triangular matrix A, packed columnwise in
+*          a linear array.  The j-th column of A is stored in the array
+*          AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  B       (input/output) COMPLEX*16 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 ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTPSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTPTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         IF( UPPER ) THEN
+            JC = 1
+            DO 10 INFO = 1, N
+               IF( AP( JC+INFO-1 ).EQ.ZERO )
+     $            RETURN
+               JC = JC + INFO
+   10       CONTINUE
+         ELSE
+            JC = 1
+            DO 20 INFO = 1, N
+               IF( AP( JC ).EQ.ZERO )
+     $            RETURN
+               JC = JC + N - INFO + 1
+   20       CONTINUE
+         END IF
+      END IF
+      INFO = 0
+*
+*     Solve  A * x = b,  A**T * x = b,  or  A**H * x = b.
+*
+      DO 30 J = 1, NRHS
+         CALL ZTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
+   30 CONTINUE
+*
+      RETURN
+*
+*     End of ZTPTRS
+*
+      END
diff --git a/SRC/ztrcon.f b/SRC/ztrcon.f
new file mode 100644
index 00000000..755072e6
--- /dev/null
+++ b/SRC/ztrcon.f
@@ -0,0 +1,204 @@
+      SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, 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          DIAG, NORM, UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRCON 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) 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).
+*
+*  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 (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
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH, ZLANTR
+      EXTERNAL           LSAME, IZAMAX, DLAMCH, ZLANTR
+*     ..
+*     .. 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
+      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( 'ZTRCON', -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 = ZLANTR( NORM, UPLO, DIAG, N, N, A, LDA, RWORK )
+*
+*     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 ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL ZLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
+     $                      LDA, WORK, SCALE, RWORK, INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL ZLATRS( UPLO, 'Conjugate transpose', DIAG, NORMIN,
+     $                      N, A, LDA, WORK, SCALE, RWORK, INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = IZAMAX( N, WORK, 1 )
+               XNORM = CABS1( WORK( IX ) )
+               IF( SCALE.LT.XNORM*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 / ANORM ) / AINVNM
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of ZTRCON
+*
+      END
diff --git a/SRC/ztrevc.f b/SRC/ztrevc.f
new file mode 100644
index 00000000..21142f42
--- /dev/null
+++ b/SRC/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/ztrexc.f b/SRC/ztrexc.f
new file mode 100644
index 00000000..69313696
--- /dev/null
+++ b/SRC/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/ztrrfs.f b/SRC/ztrrfs.f
new file mode 100644
index 00000000..364f5113
--- /dev/null
+++ b/SRC/ztrrfs.f
@@ -0,0 +1,382 @@
+      SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
+     $                   LDX, FERR, BERR, 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          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDA, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRRFS provides error bounds and backward error estimates for the
+*  solution to a system of linear equations with a triangular
+*  coefficient matrix.
+*
+*  The solution matrix X must be computed by ZTRTRS or some other
+*  means before entering this routine.  ZTRRFS does not do iterative
+*  refinement because doing so cannot improve the backward error.
+*
+*  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)
+*
+*  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 matrices B and X.  NRHS >= 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).
+*
+*  B       (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)
+*          The 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) 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
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      CHARACTER          TRANSN, TRANST
+      INTEGER            I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZLACN2, ZTRMV, ZTRSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRRFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANSN = 'N'
+         TRANST = 'C'
+      ELSE
+         TRANSN = 'C'
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 250 J = 1, NRHS
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL ZCOPY( N, X( 1, J ), 1, WORK, 1 )
+         CALL ZTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK, 1 )
+         CALL ZAXPY( N, -ONE, B( 1, J ), 1, WORK, 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 20 I = 1, N
+            RWORK( I ) = CABS1( B( I, J ) )
+   20    CONTINUE
+*
+         IF( NOTRAN ) THEN
+*
+*           Compute abs(A)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 40 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 30 I = 1, K
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   30                CONTINUE
+   40             CONTINUE
+               ELSE
+                  DO 60 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 50 I = 1, K - 1
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   50                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+   60             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 80 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 70 I = K, N
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   70                CONTINUE
+   80             CONTINUE
+               ELSE
+                  DO 100 K = 1, N
+                     XK = CABS1( X( K, J ) )
+                     DO 90 I = K + 1, N
+                        RWORK( I ) = RWORK( I ) + CABS1( A( I, K ) )*XK
+   90                CONTINUE
+                     RWORK( K ) = RWORK( K ) + XK
+  100             CONTINUE
+               END IF
+            END IF
+         ELSE
+*
+*           Compute abs(A**H)*abs(X) + abs(B).
+*
+            IF( UPPER ) THEN
+               IF( NOUNIT ) THEN
+                  DO 120 K = 1, N
+                     S = ZERO
+                     DO 110 I = 1, K
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  110                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  120             CONTINUE
+               ELSE
+                  DO 140 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 130 I = 1, K - 1
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  130                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  140             CONTINUE
+               END IF
+            ELSE
+               IF( NOUNIT ) THEN
+                  DO 160 K = 1, N
+                     S = ZERO
+                     DO 150 I = K, N
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  150                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  160             CONTINUE
+               ELSE
+                  DO 180 K = 1, N
+                     S = CABS1( X( K, J ) )
+                     DO 170 I = K + 1, N
+                        S = S + CABS1( A( I, K ) )*CABS1( X( I, J ) )
+  170                CONTINUE
+                     RWORK( K ) = RWORK( K ) + S
+  180             CONTINUE
+               END IF
+            END IF
+         END IF
+         S = ZERO
+         DO 190 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
+            ELSE
+               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
+     $             ( RWORK( I )+SAFE1 ) )
+            END IF
+  190    CONTINUE
+         BERR( J ) = S
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use ZLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 200 I = 1, N
+            IF( RWORK( I ).GT.SAFE2 ) THEN
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
+            ELSE
+               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
+     $                      SAFE1
+            END IF
+  200    CONTINUE
+*
+         KASE = 0
+  210    CONTINUE
+         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**H).
+*
+               CALL ZTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK, 1 )
+               DO 220 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  220          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 230 I = 1, N
+                  WORK( I ) = RWORK( I )*WORK( I )
+  230          CONTINUE
+               CALL ZTRSV( UPLO, TRANSN, DIAG, N, A, LDA, WORK, 1 )
+            END IF
+            GO TO 210
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 240 I = 1, N
+            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
+  240    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  250 CONTINUE
+*
+      RETURN
+*
+*     End of ZTRRFS
+*
+      END
diff --git a/SRC/ztrsen.f b/SRC/ztrsen.f
new file mode 100644
index 00000000..a07a22f6
--- /dev/null
+++ b/SRC/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/ztrsna.f b/SRC/ztrsna.f
new file mode 100644
index 00000000..0f940f6d
--- /dev/null
+++ b/SRC/ztrsna.f
@@ -0,0 +1,355 @@
+      SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, S, SEP, MM, M, WORK, LDWORK, 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          HOWMNY, JOB
+      INTEGER            INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      DOUBLE PRECISION   RWORK( * ), S( * ), SEP( * )
+      COMPLEX*16         T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRSNA estimates reciprocal condition numbers for specified
+*  eigenvalues and/or right eigenvectors of a complex upper triangular
+*  matrix T (or of any matrix Q*T*Q**H with Q unitary).
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for
+*          eigenvalues (S) or eigenvectors (SEP):
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for eigenvectors only (SEP);
+*          = 'B': for both eigenvalues and eigenvectors (S and SEP).
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute condition numbers for all eigenpairs;
+*          = 'S': compute condition numbers for selected eigenpairs
+*                 specified by the array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+*          condition numbers are required. To select condition numbers
+*          for the j-th eigenpair, SELECT(j) must be set to .TRUE..
+*          If HOWMNY = 'A', SELECT is not referenced.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input) COMPLEX*16 array, dimension (LDT,N)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  VL      (input) COMPLEX*16 array, dimension (LDVL,M)
+*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
+*          (or of any Q*T*Q**H with Q unitary), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VL, as returned by
+*          ZHSEIN or ZTREVC.
+*          If JOB = 'V', VL is not referenced.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.
+*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
+*
+*  VR      (input) COMPLEX*16 array, dimension (LDVR,M)
+*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
+*          (or of any Q*T*Q**H with Q unitary), corresponding to the
+*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+*          must be stored in consecutive columns of VR, as returned by
+*          ZHSEIN or ZTREVC.
+*          If JOB = 'V', VR is not referenced.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.
+*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
+*
+*  S       (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
+*          selected eigenvalues, stored in consecutive elements of the
+*          array. Thus S(j), SEP(j), and the j-th columns of VL and VR
+*          all correspond to the same eigenpair (but not in general the
+*          j-th eigenpair, unless all eigenpairs are selected).
+*          If JOB = 'V', S is not referenced.
+*
+*  SEP     (output) DOUBLE PRECISION array, dimension (MM)
+*          If JOB = 'V' or 'B', the estimated reciprocal condition
+*          numbers of the selected eigenvectors, stored in consecutive
+*          elements of the array.
+*          If JOB = 'E', SEP is not referenced.
+*
+*  MM      (input) INTEGER
+*          The number of elements in the arrays S (if JOB = 'E' or 'B')
+*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of elements of the arrays S and/or SEP actually
+*          used to store the estimated condition numbers.
+*          If HOWMNY = 'A', M is set to N.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,N+6)
+*          If JOB = 'E', WORK is not referenced.
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*          If JOB = 'E', RWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The reciprocal of the condition number of an eigenvalue lambda is
+*  defined as
+*
+*          S(lambda) = |v'*u| / (norm(u)*norm(v))
+*
+*  where u and v are the right and left eigenvectors of T corresponding
+*  to lambda; v' denotes the conjugate transpose of v, and norm(u)
+*  denotes the Euclidean norm. These reciprocal condition numbers always
+*  lie between zero (very badly conditioned) and one (very well
+*  conditioned). If n = 1, S(lambda) is defined to be 1.
+*
+*  An approximate error bound for a computed eigenvalue W(i) is given by
+*
+*                      EPS * norm(T) / S(i)
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal of the condition number of the right eigenvector u
+*  corresponding to lambda is defined as follows. Suppose
+*
+*              T = ( lambda  c  )
+*                  (   0    T22 )
+*
+*  Then the reciprocal condition number is
+*
+*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
+*
+*  where sigma-min denotes the smallest singular value. We approximate
+*  the smallest singular value by the reciprocal of an estimate of the
+*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
+*  defined to be abs(T(1,1)).
+*
+*  An approximate error bound for a computed right eigenvector VR(i)
+*  is given by
+*
+*                      EPS * norm(T) / SEP(i)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D0+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            SOMCON, WANTBH, WANTS, WANTSP
+      CHARACTER          NORMIN
+      INTEGER            I, IERR, IX, J, K, KASE, KS
+      DOUBLE PRECISION   BIGNUM, EPS, EST, LNRM, RNRM, SCALE, SMLNUM,
+     $                   XNORM
+      COMPLEX*16         CDUM, PROD
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+      COMPLEX*16         DUMMY( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH, DZNRM2
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, IZAMAX, DLAMCH, DZNRM2, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDRSCL, ZLACN2, ZLACPY, ZLATRS, ZTREXC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, 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
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+      SOMCON = LSAME( HOWMNY, 'S' )
+*
+*     Set M to the number of eigenpairs for which condition numbers are
+*     to be computed.
+*
+      IF( SOMCON ) 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.WANTS .AND. .NOT.WANTSP ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -13
+      ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
+         INFO = -16
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRSNA', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( 1 ) )
+     $         RETURN
+         END IF
+         IF( WANTS )
+     $      S( 1 ) = ONE
+         IF( WANTSP )
+     $      SEP( 1 ) = ABS( T( 1, 1 ) )
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+      KS = 1
+      DO 50 K = 1, N
+*
+         IF( SOMCON ) THEN
+            IF( .NOT.SELECT( K ) )
+     $         GO TO 50
+         END IF
+*
+         IF( WANTS ) THEN
+*
+*           Compute the reciprocal condition number of the k-th
+*           eigenvalue.
+*
+            PROD = ZDOTC( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+            RNRM = DZNRM2( N, VR( 1, KS ), 1 )
+            LNRM = DZNRM2( N, VL( 1, KS ), 1 )
+            S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
+*
+         END IF
+*
+         IF( WANTSP ) THEN
+*
+*           Estimate the reciprocal condition number of the k-th
+*           eigenvector.
+*
+*           Copy the matrix T to the array WORK and swap the k-th
+*           diagonal element to the (1,1) position.
+*
+            CALL ZLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
+            CALL ZTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, K, 1, IERR )
+*
+*           Form  C = T22 - lambda*I in WORK(2:N,2:N).
+*
+            DO 20 I = 2, N
+               WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
+   20       CONTINUE
+*
+*           Estimate a lower bound for the 1-norm of inv(C'). The 1st
+*           and (N+1)th columns of WORK are used to store work vectors.
+*
+            SEP( KS ) = ZERO
+            EST = ZERO
+            KASE = 0
+            NORMIN = 'N'
+   30       CONTINUE
+            CALL ZLACN2( N-1, WORK( 1, N+1 ), WORK, EST, KASE, ISAVE )
+*
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve C'*x = scale*b
+*
+                  CALL ZLATRS( 'Upper', 'Conjugate transpose',
+     $                         'Nonunit', NORMIN, N-1, WORK( 2, 2 ),
+     $                         LDWORK, WORK, SCALE, RWORK, IERR )
+               ELSE
+*
+*                 Solve C*x = scale*b
+*
+                  CALL ZLATRS( 'Upper', 'No transpose', 'Nonunit',
+     $                         NORMIN, N-1, WORK( 2, 2 ), LDWORK, WORK,
+     $                         SCALE, RWORK, IERR )
+               END IF
+               NORMIN = 'Y'
+               IF( SCALE.NE.ONE ) THEN
+*
+*                 Multiply by 1/SCALE if doing so will not cause
+*                 overflow.
+*
+                  IX = IZAMAX( N-1, WORK, 1 )
+                  XNORM = CABS1( WORK( IX, 1 ) )
+                  IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $               GO TO 40
+                  CALL ZDRSCL( N, SCALE, WORK, 1 )
+               END IF
+               GO TO 30
+            END IF
+*
+            SEP( KS ) = ONE / MAX( EST, SMLNUM )
+         END IF
+*
+   40    CONTINUE
+         KS = KS + 1
+   50 CONTINUE
+      RETURN
+*
+*     End of ZTRSNA
+*
+      END
diff --git a/SRC/ztrsyl.f b/SRC/ztrsyl.f
new file mode 100644
index 00000000..d2e0ecc7
--- /dev/null
+++ b/SRC/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/ztrti2.f b/SRC/ztrti2.f
new file mode 100644
index 00000000..73c7bbc3
--- /dev/null
+++ b/SRC/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/ztrtri.f b/SRC/ztrtri.f
new file mode 100644
index 00000000..7caa9771
--- /dev/null
+++ b/SRC/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/ztrtrs.f b/SRC/ztrtrs.f
new file mode 100644
index 00000000..b42d5a58
--- /dev/null
+++ b/SRC/ztrtrs.f
@@ -0,0 +1,148 @@
+      SUBROUTINE ZTRTRS( 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 ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRTRS solves a triangular system of the form
+*
+*     A * X = B,  A**T * X = B,  or  A**H * 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)
+*
+*  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) 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).
+*
+*  B       (input/output) COMPLEX*16 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 ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTRSM
+*     ..
+*     .. 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( 'ZTRTRS', -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,  A**T * x = b,  or  A**H * x = b.
+*
+      CALL ZTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+     $            LDB )
+*
+      RETURN
+*
+*     End of ZTRTRS
+*
+      END
diff --git a/SRC/ztzrqf.f b/SRC/ztzrqf.f
new file mode 100644
index 00000000..9217b441
--- /dev/null
+++ b/SRC/ztzrqf.f
@@ -0,0 +1,173 @@
+      SUBROUTINE ZTZRQF( 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 ..
+      COMPLEX*16         A( LDA, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine ZTZRZF.
+*
+*  ZTZRQF 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.
+*
+*  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 ), whose conjugate transpose 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         CONE, CZERO
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K, M1
+      COMPLEX*16         ALPHA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGEMV, ZGERC, ZLACGV,
+     $                   ZLARFP
+*     ..
+*     .. 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( 'ZTZRQF', -INFO )
+         RETURN
+      END IF
+*
+*     Perform the factorization.
+*
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = CZERO
+   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.
+*
+            A( K, K ) = DCONJG( A( K, K ) )
+            CALL ZLACGV( N-M, A( K, M1 ), LDA )
+            ALPHA = A( K, K )
+            CALL ZLARFP( N-M+1, ALPHA, A( K, M1 ), LDA, TAU( K ) )
+            A( K, K ) = ALPHA
+            TAU( K ) = DCONJG( TAU( K ) )
+*
+            IF( TAU( K ).NE.CZERO .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 ZCOPY( K-1, A( 1, K ), 1, TAU, 1 )
+*
+*              Form   w = a( k ) + B*z( k )  in TAU.
+*
+               CALL ZGEMV( 'No transpose', K-1, N-M, CONE, A( 1, M1 ),
+     $                     LDA, A( K, M1 ), LDA, CONE, TAU, 1 )
+*
+*              Now form  a( k ) := a( k ) - conjg(tau)*w
+*              and       B      := B      - conjg(tau)*w*z( k )'.
+*
+               CALL ZAXPY( K-1, -DCONJG( TAU( K ) ), TAU, 1, A( 1, K ),
+     $                     1 )
+               CALL ZGERC( K-1, N-M, -DCONJG( TAU( K ) ), TAU, 1,
+     $                     A( K, M1 ), LDA, A( 1, M1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZTZRQF
+*
+      END
diff --git a/SRC/ztzrzf.f b/SRC/ztzrzf.f
new file mode 100644
index 00000000..5c9c6543
--- /dev/null
+++ b/SRC/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/zung2l.f b/SRC/zung2l.f
new file mode 100644
index 00000000..29178b90
--- /dev/null
+++ b/SRC/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/zung2r.f b/SRC/zung2r.f
new file mode 100644
index 00000000..cd89f26e
--- /dev/null
+++ b/SRC/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/zungbr.f b/SRC/zungbr.f
new file mode 100644
index 00000000..94f74820
--- /dev/null
+++ b/SRC/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/zunghr.f b/SRC/zunghr.f
new file mode 100644
index 00000000..fcf32abf
--- /dev/null
+++ b/SRC/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/zungl2.f b/SRC/zungl2.f
new file mode 100644
index 00000000..502411b4
--- /dev/null
+++ b/SRC/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/zunglq.f b/SRC/zunglq.f
new file mode 100644
index 00000000..ab4a018f
--- /dev/null
+++ b/SRC/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/zungql.f b/SRC/zungql.f
new file mode 100644
index 00000000..4232abea
--- /dev/null
+++ b/SRC/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/zungqr.f b/SRC/zungqr.f
new file mode 100644
index 00000000..bf5c6997
--- /dev/null
+++ b/SRC/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/zungr2.f b/SRC/zungr2.f
new file mode 100644
index 00000000..70f52314
--- /dev/null
+++ b/SRC/zungr2.f
@@ -0,0 +1,134 @@
+      SUBROUTINE ZUNGR2( 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
+*  =======
+*
+*  ZUNGR2 generates an m by n complex 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 ZGERQF.
+*
+*  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 (m-k+i)-th row must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by ZGERQF 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) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGERQF.
+*
+*  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, II, 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( 'ZUNGR2', -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
+*
+         CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
+         A( II, N-M+II ) = ONE
+         CALL ZLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
+     $               DCONJG( TAU( I ) ), A, LDA, WORK )
+         CALL ZSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
+         CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA )
+         A( II, N-M+II ) = ONE - DCONJG( 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 ZUNGR2
+*
+      END
diff --git a/SRC/zungrq.f b/SRC/zungrq.f
new file mode 100644
index 00000000..dc34b253
--- /dev/null
+++ b/SRC/zungrq.f
@@ -0,0 +1,223 @@
+      SUBROUTINE ZUNGRQ( 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
+*  =======
+*
+*  ZUNGRQ generates an M-by-N complex 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 ZGERQF.
+*
+*  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 (m-k+i)-th row must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by ZGERQF 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) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGERQF.
+*
+*  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, II, IINFO, IWS, J, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNGR2
+*     ..
+*     .. 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, 'ZUNGRQ', ' ', 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( 'ZUNGRQ', -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, 'ZUNGRQ', ' ', 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, 'ZUNGRQ', ' ', 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 ZUNGR2( 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 ZLARFT( '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 ZLARFB( 'Right', 'Conjugate 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 ZUNGR2( 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 ZUNGRQ
+*
+      END
diff --git a/SRC/zungtr.f b/SRC/zungtr.f
new file mode 100644
index 00000000..5de7c109
--- /dev/null
+++ b/SRC/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/zunm2l.f b/SRC/zunm2l.f
new file mode 100644
index 00000000..287f6207
--- /dev/null
+++ b/SRC/zunm2l.f
@@ -0,0 +1,196 @@
+      SUBROUTINE ZUNM2L( 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
+*  =======
+*
+*  ZUNM2L 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 ZGEQLF. 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
+*          ZGEQLF 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) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQLF.
+*
+*  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, 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( 'ZUNM2L', -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) or H(i)' is applied to C(1:m-k+i,1:n)
+*
+            MI = M - K + I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,1:n-k+i)
+*
+            NI = N - K + I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = TAU( I )
+         ELSE
+            TAUI = DCONJG( TAU( I ) )
+         END IF
+         AII = A( NQ-K+I, I )
+         A( NQ-K+I, I ) = ONE
+         CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK )
+         A( NQ-K+I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of ZUNM2L
+*
+      END
diff --git a/SRC/zunm2r.f b/SRC/zunm2r.f
new file mode 100644
index 00000000..7d4c067a
--- /dev/null
+++ b/SRC/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/zunmbr.f b/SRC/zunmbr.f
new file mode 100644
index 00000000..b32ce338
--- /dev/null
+++ b/SRC/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/zunmhr.f b/SRC/zunmhr.f
new file mode 100644
index 00000000..4424540d
--- /dev/null
+++ b/SRC/zunmhr.f
@@ -0,0 +1,201 @@
+      SUBROUTINE ZUNMHR( 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 ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNMHR 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 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 ZGEHRD:
+*
+*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  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': apply Q  (No transpose)
+*          = 'C': apply Q**H (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.
+*
+*  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).
+*          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) COMPLEX*16 array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by ZGEHRD.
+*
+*  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) COMPLEX*16 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 ZGEHRD.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. 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           XERBLA, ZUNMQR
+*     ..
+*     .. 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, 'C' ) )
+     $          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, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 )
+         ELSE
+            NB = ILAENV( 1, 'ZUNMQR', 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( 'ZUNMHR', -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 ZUNMQR( 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 ZUNMHR
+*
+      END
diff --git a/SRC/zunml2.f b/SRC/zunml2.f
new file mode 100644
index 00000000..cced4a77
--- /dev/null
+++ b/SRC/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/zunmlq.f b/SRC/zunmlq.f
new file mode 100644
index 00000000..b1708757
--- /dev/null
+++ b/SRC/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/zunmql.f b/SRC/zunmql.f
new file mode 100644
index 00000000..3a9edb45
--- /dev/null
+++ b/SRC/zunmql.f
@@ -0,0 +1,261 @@
+      SUBROUTINE ZUNMQL( 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
+*  =======
+*
+*  ZUNMQL 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 ZGEQLF. 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':  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
+*          ZGEQLF 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) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQLF.
+*
+*  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, IINFO, IWS, 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, ZUNM2L
+*     ..
+*     .. 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( 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, 'ZUNMQL', 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( 'ZUNMQL', -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, 'ZUNMQL', 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 ZUNM2L( 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 ZLARFT( '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 ZLARFB( 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 ZUNMQL
+*
+      END
diff --git a/SRC/zunmqr.f b/SRC/zunmqr.f
new file mode 100644
index 00000000..f9b1e98f
--- /dev/null
+++ b/SRC/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/zunmr2.f b/SRC/zunmr2.f
new file mode 100644
index 00000000..c476d19f
--- /dev/null
+++ b/SRC/zunmr2.f
@@ -0,0 +1,198 @@
+      SUBROUTINE ZUNMR2( 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
+*  =======
+*
+*  ZUNMR2 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 ZGERQF. 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
+*          ZGERQF 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 ZGERQF.
+*
+*  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, 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( 'ZUNMR2', -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) or H(i)' is applied to C(1:m-k+i,1:n)
+*
+            MI = M - K + I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,1:n-k+i)
+*
+            NI = N - K + I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = DCONJG( TAU( I ) )
+         ELSE
+            TAUI = TAU( I )
+         END IF
+         CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA )
+         AII = A( I, NQ-K+I )
+         A( I, NQ-K+I ) = ONE
+         CALL ZLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK )
+         A( I, NQ-K+I ) = AII
+         CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of ZUNMR2
+*
+      END
diff --git a/SRC/zunmr3.f b/SRC/zunmr3.f
new file mode 100644
index 00000000..111c1c95
--- /dev/null
+++ b/SRC/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/zunmrq.f b/SRC/zunmrq.f
new file mode 100644
index 00000000..99a3ea21
--- /dev/null
+++ b/SRC/zunmrq.f
@@ -0,0 +1,268 @@
+      SUBROUTINE ZUNMRQ( 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
+*  =======
+*
+*  ZUNMRQ 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 ZGERQF. 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':  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
+*          ZGERQF 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 ZGERQF.
+*
+*  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, IINFO, IWS, 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, ZUNMR2
+*     ..
+*     .. 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( 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, 'ZUNMRQ', 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( 'ZUNMRQ', -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, '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 ZUNMR2( 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 = '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 ZLARFT( '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 ZLARFB( 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 ZUNMRQ
+*
+      END
diff --git a/SRC/zunmrz.f b/SRC/zunmrz.f
new file mode 100644
index 00000000..dcce6869
--- /dev/null
+++ b/SRC/zunmrz.f
@@ -0,0 +1,297 @@
+      SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     January 2007
+*
+*     .. 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
+         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, '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
diff --git a/SRC/zunmtr.f b/SRC/zunmtr.f
new file mode 100644
index 00000000..a3b2b12e
--- /dev/null
+++ b/SRC/zunmtr.f
@@ -0,0 +1,222 @@
+      SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, 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, UPLO
+      INTEGER            INFO, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNMTR 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 of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by ZHETRD:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangle of A contains elementary reflectors
+*                 from ZHETRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from ZHETRD.
+*
+*  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.
+*
+*  A       (input) COMPLEX*16 array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by ZHETRD.
+*
+*  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) COMPLEX*16 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 ZHETRD.
+*
+*  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
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, UPPER
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNMQL, ZUNMQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
+     $          THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( UPPER ) THEN
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1,
+     $              -1 )
+            ELSE
+               NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1,
+     $              -1 )
+            END IF
+         ELSE
+            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
+         END IF
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMTR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( LEFT ) THEN
+         MI = M - 1
+         NI = N
+      ELSE
+         MI = M
+         NI = N - 1
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to ZHETRD with UPLO = 'U'
+*
+         CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
+     $                LDC, WORK, LWORK, IINFO )
+      ELSE
+*
+*        Q was determined by a call to ZHETRD with UPLO = 'L'
+*
+         IF( LEFT ) THEN
+            I1 = 2
+            I2 = 1
+         ELSE
+            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
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNMTR
+*
+      END
diff --git a/SRC/zupgtr.f b/SRC/zupgtr.f
new file mode 100644
index 00000000..1c8039d9
--- /dev/null
+++ b/SRC/zupgtr.f
@@ -0,0 +1,161 @@
+      SUBROUTINE ZUPGTR( 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 ..
+      COMPLEX*16         AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUPGTR generates a complex unitary matrix Q which is defined as the
+*  product of n-1 elementary reflectors H(i) of order n, as returned by
+*  ZHPTRD 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 ZHPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to ZHPTRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)
+*          The vectors which define the elementary reflectors, as
+*          returned by ZHPTRD.
+*
+*  TAU     (input) COMPLEX*16 array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZHPTRD.
+*
+*  Q       (output) COMPLEX*16 array, dimension (LDQ,N)
+*          The N-by-N unitary matrix Q.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N-1)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IINFO, IJ, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNG2L, ZUNG2R
+*     ..
+*     .. 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( 'ZUPGTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to ZHPTRD 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 ) = CZERO
+   20    CONTINUE
+         DO 30 I = 1, N - 1
+            Q( I, N ) = CZERO
+   30    CONTINUE
+         Q( N, N ) = CONE
+*
+*        Generate Q(1:n-1,1:n-1)
+*
+         CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to ZHPTRD 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 ) = CONE
+         DO 40 I = 2, N
+            Q( I, 1 ) = CZERO
+   40    CONTINUE
+         IJ = 3
+         DO 60 J = 2, N
+            Q( 1, J ) = CZERO
+            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 ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
+     $                   IINFO )
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZUPGTR
+*
+      END
diff --git a/SRC/zupmtr.f b/SRC/zupmtr.f
new file mode 100644
index 00000000..8d539609
--- /dev/null
+++ b/SRC/zupmtr.f
@@ -0,0 +1,267 @@
+      SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, 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, UPLO
+      INTEGER            INFO, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         AP( * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUPMTR 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 of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  nq-1 elementary reflectors, as returned by ZHPTRD using packed
+*  storage:
+*
+*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangular packed storage used in previous
+*                 call to ZHPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to ZHPTRD.
+*
+*  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.
+*
+*  AP      (input) COMPLEX*16 array, dimension
+*                               (M*(M+1)/2) if SIDE = 'L'
+*                               (N*(N+1)/2) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by ZHPTRD.  AP is modified by the routine but
+*          restored on exit.
+*
+*  TAU     (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L'
+*                                     or (N-1) if SIDE = 'R'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZHPTRD.
+*
+*  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) 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            FORWRD, LEFT, NOTRAN, UPPER
+      INTEGER            I, I1, I2, I3, IC, II, 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' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUPMTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to ZHPTRD with UPLO = 'U'
+*
+         FORWRD = ( LEFT .AND. NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. .NOT.NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+         ELSE
+            MI = M
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IF( LEFT ) THEN
+*
+*              H(i) or H(i)' is applied to C(1:i,1:n)
+*
+               MI = I
+            ELSE
+*
+*              H(i) or H(i)' is applied to C(1:m,1:i)
+*
+               NI = I
+            END IF
+*
+*           Apply H(i) or H(i)'
+*
+            IF( NOTRAN ) THEN
+               TAUI = TAU( I )
+            ELSE
+               TAUI = DCONJG( TAU( I ) )
+            END IF
+            AII = AP( II )
+            AP( II ) = ONE
+            CALL ZLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC,
+     $                  WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + I + 2
+            ELSE
+               II = II - I - 1
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Q was determined by a call to ZHPTRD with UPLO = 'L'.
+*
+         FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $            ( .NOT.LEFT .AND. NOTRAN )
+*
+         IF( FORWRD ) THEN
+            I1 = 1
+            I2 = NQ - 1
+            I3 = 1
+            II = 2
+         ELSE
+            I1 = NQ - 1
+            I2 = 1
+            I3 = -1
+            II = NQ*( NQ+1 ) / 2 - 1
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         DO 20 I = I1, I2, I3
+            AII = AP( II )
+            AP( II ) = ONE
+            IF( LEFT ) THEN
+*
+*              H(i) or H(i)' is applied to C(i+1:m,1:n)
+*
+               MI = M - I
+               IC = I + 1
+            ELSE
+*
+*              H(i) or H(i)' is applied to C(1:m,i+1:n)
+*
+               NI = N - I
+               JC = I + 1
+            END IF
+*
+*           Apply H(i) or H(i)'
+*
+            IF( NOTRAN ) THEN
+               TAUI = TAU( I )
+            ELSE
+               TAUI = DCONJG( TAU( I ) )
+            END IF
+            CALL ZLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ),
+     $                  LDC, WORK )
+            AP( II ) = AII
+*
+            IF( FORWRD ) THEN
+               II = II + NQ - I + 1
+            ELSE
+               II = II - NQ + I - 2
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZUPMTR
+*
+      END